Dominique Makowski, Tam Pham, Zen J. Lau, Adrian Raine, & S.H. Annabel Chen

Methods

Packages & Data

Packages

library(tidyverse)
library(easystats)
> # Attaching packages
> <U+2714> insight     0.11.1.1   <U+2714> bayestestR  0.8.0.1 
> <U+2714> performance 0.6.1      <U+2714> parameters  0.10.1  
> <U+2714> see         0.6.1.1    <U+2714> effectsize  0.4.1.1 
> <U+2714> correlation 0.5.0      <U+2714> modelbased  0.4.0   
> <U+2714> report      0.2.0      
> Warnings or errors in CRAN checks for package(s) 'insight', 'parameters'.
set.seed(333)

Data

labels <- read.csv("labels.csv", stringsAsFactors = FALSE) %>% 
  mutate(Item = paste0(Questionnaire, "_", Item))
df_raw <- read.csv("data.csv", stringsAsFactors = FALSE)

Preprocessing

df_raw <- df_raw %>% 
  mutate(Participant = paste0("S", 1:nrow(df_raw)),
         Sex = as.factor(Sex))

paste("The initial sample included", report::report_participants(df_raw))
> [1] "The initial sample included 1011 participants (Mean age = 25.6, SD = 7.9, range: [13.0, 73.51]; 55.1% females; Mean education = 3.4, SD = 2.2, range: [-7, 10])"

Measures Scoring

Utility Functions

# Reverse negative items
reverse <- function(x, mini, maxi){
  maxi - x + mini
}


# Descriptive statistics
descriptive_statistics <- function(df, begins_with){
  df %>% 
    select(dplyr::starts_with(begins_with)) %>% 
    report() %>% 
    as.data.frame() %>% 
    select(-one_of(c("n_Obs", "Median", "MAD", "n_Missing"))) %>% 
    print()
  
  plot(df %>% 
    select(dplyr::starts_with(begins_with)) %>% 
    bayestestR::estimate_density(method = "KernSmooth") %>% 
    plot() + 
    see::theme_modern())
}

Deception and Lying Profile (LIE)

We rescaled the LIE variables, originally scored on a -10 to 10 scale, to -5 to 5, so that the coefficients are more easily interpretable (i.e., refers to a change of 10% of the scale).

df_raw[stringr::str_detect(names(df_raw), "LIE_")] <- effectsize::change_scale(df_raw[stringr::str_detect(names(df_raw), "LIE_")], from = c(-10, 10), to = c(-5, 5))

Psychopathy (TRIMP)

df_raw <- df_raw %>%
   # Transform to numeric
  mutate_at(vars(starts_with("TRIMP")), function(x) {
    ifelse(x == "TRUE", 3,
           ifelse(x == "somewhat true", 2,
                  ifelse(x == "somewhat false", 1, 0)))
    }) %>%
  # Reverse items
  mutate_at(vars("TRIMP_2", "TRIMP_4", "TRIMP_10", "TRIMP_11", "TRIMP_16", "TRIMP_21", "TRIMP_25", "TRIMP_30", "TRIMP_33", "TRIMP_35", "TRIMP_39", "TRIMP_41", "TRIMP_44", "TRIMP_47", "TRIMP_50", "TRIMP_52", "TRIMP_57"), reverse, mini = 0, maxi = 3) %>% 
  # Compute scores
      ## Boldness
  mutate(
    TRIMP_Boldness = (TRIMP_1 + TRIMP_16
                      + TRIMP_7 + TRIMP_32
                      + TRIMP_10 + TRIMP_28
                      + TRIMP_13 + TRIMP_41
                      + TRIMP_19 + TRIMP_38 + TRIMP_57
                      + TRIMP_4 + TRIMP_47 
                      + TRIMP_22 + TRIMP_35
                      + TRIMP_25 + TRIMP_50
                      + TRIMP_44 + TRIMP_54)/19,
    TRIMP_Boldness_Optimism = (TRIMP_1 + TRIMP_16)/2,
    TRIMP_Boldness_Resilience = (TRIMP_7 + TRIMP_32)/2,
    TRIMP_Boldness_Courage = (TRIMP_10 + TRIMP_28)/2,
    TRIMP_Boldness_Dominance = (TRIMP_13 + TRIMP_41)/2,
    TRIMP_Boldness_Persuasiveness = (TRIMP_19 + TRIMP_38 + TRIMP_57)/3,
    TRIMP_Boldness_Intrepidness = (TRIMP_4 + TRIMP_47)/2,
    TRIMP_Boldness_ToleranceForUncertainty = (TRIMP_22 + TRIMP_35)/2,
    TRIMP_Boldness_SelfConfidence = (TRIMP_25 + TRIMP_50)/2,
    TRIMP_Boldness_SocialAssurance = (TRIMP_44 + TRIMP_54)/2
) %>% 
      ## Meanness
  mutate(
    TRIMP_Meanness = (TRIMP_2 + TRIMP_8 + TRIMP_11 + TRIMP_20 + TRIMP_29 + TRIMP_33 + TRIMP_36 + TRIMP_48 + TRIMP_52 + TRIMP_55 
                      + TRIMP_6 + TRIMP_45
                      + TRIMP_14
                      + TRIMP_17 + TRIMP_23 + TRIMP_26 + TRIMP_42
                      + TRIMP_39
                      + TRIMP_40)/19,
    TRIMP_Meanness_Empathy = (TRIMP_2 + TRIMP_8 + TRIMP_11 + TRIMP_20 + TRIMP_29 + TRIMP_33 + TRIMP_36 + TRIMP_48 + TRIMP_52 + TRIMP_55)/10,
    TRIMP_Meanness_ExcitementSeeking = (TRIMP_6 + TRIMP_45)/2,
    TRIMP_Meanness_PhysicalAggression = TRIMP_14,
    TRIMP_Meanness_RelationalAggression = (TRIMP_17 + TRIMP_23 + TRIMP_26 + TRIMP_42)/4,
    TRIMP_Meanness_Honesty = TRIMP_39,
    TRIMP_Meanness_DestructiveAggression = TRIMP_40
) %>% 
     ## Disinhibition
  mutate(
    TRIMP_Disinhibition = (
      TRIMP_3 + TRIMP_46 + 
        TRIMP_5 + TRIMP_30 + 
        TRIMP_9 + TRIMP_15 + TRIMP_37 + TRIMP_51 +
        TRIMP_12 + TRIMP_18 + TRIMP_49 + TRIMP_56 +
        TRIMP_21 +
        TRIMP_24 + TRIMP_43 + TRIMP_53 + TRIMP_58 +
        TRIMP_27 +
        TRIMP_31 +
        TRIMP_34)/20,
    TRIMP_Disinhibition_ImpatienceUrgency = (TRIMP_3 + TRIMP_46)/2,
    TRIMP_Disinhibition_Dependability = (TRIMP_5 + TRIMP_30)/2,
    TRIMP_Disinhibition_ProblematicImpulsivity = (TRIMP_9 + TRIMP_15 + TRIMP_37 + TRIMP_51)/4,
    TRIMP_Disinhibition_Irresponsibility = (TRIMP_12 + TRIMP_18 + TRIMP_49 + TRIMP_56)/4,
    TRIMP_Disinhibition_PlanfulControl = TRIMP_21,
    TRIMP_Disinhibition_Theft = (TRIMP_24 + TRIMP_43 + TRIMP_53 + TRIMP_58)/4,
    TRIMP_Disinhibition_Alienation = TRIMP_27,
    TRIMP_Disinhibition_BoredomProneness = TRIMP_31,
    TRIMP_Disinhibition_Fraud = TRIMP_34
) %>% 
  ## General
      mutate(TRIMP_General = (TRIMP_Boldness*19 + TRIMP_Meanness*19 + TRIMP_Disinhibition*20)/58
) %>%
  # Remove individual questions
  select(-matches("TRIMP_\\d"))

Narcissism (FFNI)

df_raw <- df_raw %>%
   # Transform to numeric
  mutate_at(vars(starts_with("FFNI")), function(x) {
    ifelse(x == "Disagree strongly", 1,
           ifelse(x == "Disagree a little", 2,
                  ifelse(x == "Neither agree nor disagree", 3,
                         ifelse(x == "Agree a little", 4, 5))))
  })%>%
  # Reverse items
  mutate_at(vars("FFNI_19", "FFNI_27"), reverse, mini = 1, maxi = 5) %>% 
  # Compute scores
  mutate(
    FFNI_AcclaimSeeking = (FFNI_1 + FFNI_16 + FFNI_31 + FFNI_46),
    FFNI_Distrust = (FFNI_4 + FFNI_19 + FFNI_34 + FFNI_49),
    FFNI_Entitlement = (FFNI_5 + FFNI_20 + FFNI_35 + FFNI_50),
    FFNI_Exploitativeness = (FFNI_7 + FFNI_22 + FFNI_37 + FFNI_52),
    FFNI_Indifference = (FFNI_9 + FFNI_24 + FFNI_39 + FFNI_54),
    FFNI_LackOfEmpathy = (FFNI_10 + FFNI_25 + FFNI_40 + FFNI_55),
    FFNI_Manipulativeness = (FFNI_11 + FFNI_26 + FFNI_41 + FFNI_56),
    FFNI_NeedForAdmiration = (FFNI_12 + FFNI_27 + FFNI_42 + FFNI_57),
    FFNI_ThrillSeeking = (FFNI_15 + FFNI_30 + FFNI_45 + FFNI_60),
    FFNI_General = (FFNI_AcclaimSeeking + FFNI_Entitlement + FFNI_NeedForAdmiration + FFNI_Manipulativeness + FFNI_LackOfEmpathy + FFNI_Indifference + FFNI_ThrillSeeking + FFNI_Distrust + FFNI_Exploitativeness) / 9
) %>% 
  # Remove individual questions
  select(-matches("FFNI_\\d"))

Normal Personality (IPIP6)

df_raw <- df_raw %>%
  # Transform to numeric
  mutate_at(vars(starts_with("IPIP6")), as.numeric) %>% 
  # Reverse items
  mutate_at(vars("IPIP6_6", "IPIP6_7", "IPIP6_8", "IPIP6_9", "IPIP6_11", "IPIP6_12", "IPIP6_13", "IPIP6_15", "IPIP6_17", "IPIP6_18", "IPIP6_19", "IPIP6_20", "IPIP6_21", "IPIP6_22", "IPIP6_24"), reverse, mini = 1, maxi = 7) %>% 
  # Compute scores
  mutate(
    IPIP6_Extraversion = (IPIP6_1 + IPIP6_7 + IPIP6_19 + IPIP6_23)/4,
    IPIP6_Agreableness = (IPIP6_2 + IPIP6_8 + IPIP6_14 + IPIP6_20)/4,
    IPIP6_Conscientiousness = (IPIP6_3 + IPIP6_10 + IPIP6_11 + IPIP6_22)/4,
    IPIP6_Neuroticism = (IPIP6_4 + IPIP6_15 + IPIP6_16 + IPIP6_17)/4,
    IPIP6_Openness = (IPIP6_5 + IPIP6_9 + IPIP6_13 + IPIP6_21)/4,
    IPIP6_HonestyHumility = (IPIP6_6 + IPIP6_12 + IPIP6_18 + IPIP6_24)/4
  ) %>% 
  # Remove individual questions
  select(-matches("IPIP6_\\d"))

Pathological Personality (PID-5)

df_raw <- df_raw %>%
  # Transform to numeric
  mutate_at(vars(starts_with("PID5")), function(x) {
    ifelse(x == "Very false or often false", 0,
           ifelse(x == "Sometimes or somewhat false", 1,
                  ifelse(x == "Sometimes or somewhat true", 2, 3)))
  }) %>% 
  # Compute scores
  mutate(
    PID5_NegativeAffect = (PID5_8 + PID5_9 + PID5_10 + PID5_11 + PID5_15)/5,
    PID5_Detachment = (PID5_4 + PID5_13 + PID5_14 + PID5_16 + PID5_18)/5,
    PID5_Antagonism = (PID5_17 + PID5_19 + PID5_20 + PID5_22 + PID5_25)/5,
    PID5_Disinhibition = (PID5_1 + PID5_2 + PID5_3 + PID5_5 + PID5_6)/5,
    PID5_Psychoticism = (PID5_7 + PID5_12 + PID5_21 + PID5_23 + PID5_24)/5,
    PID5_Pathology = (PID5_NegativeAffect + PID5_Detachment + PID5_Antagonism + PID5_Disinhibition + PID5_Psychoticism)/5
  ) %>% 
  # Remove individual questions
  select(-matches("PID5_\\d"))

Social Desirability (BIDR)

df_raw <- df_raw %>%
   # Reverse items
  mutate_at(vars("BIDR_1", "BIDR_3", "BIDR_5", "BIDR_8", "BIDR_9", "BIDR_11", "BIDR_12", "BIDR_13"), reverse, mini = 1, maxi = 7) %>% 
  # Compute scores
  mutate(
    BIDR_SelfDeceptiveEnhancement = (BIDR_1 + BIDR_2 + BIDR_3 + BIDR_4 + BIDR_5 + BIDR_6 + BIDR_7 + BIDR_8)/8,
    BIDR_ImpressionManagement = (BIDR_9 + BIDR_10 + BIDR_11 + BIDR_12 + BIDR_13 + BIDR_14 + BIDR_15 + BIDR_16)/8,
    BIDR_General = (BIDR_SelfDeceptiveEnhancement + BIDR_ImpressionManagement)/2
) %>% 
  # Remove individual questions
  select(-matches("BIDR_\\d"))

Impulsivity (UPPS)

df_raw <- df_raw %>%
   # Transform to numeric
  mutate_at(vars(starts_with("UPPS")), function(x) {
    ifelse(x == "Strongly Agree", 1,
           ifelse(x == "Somewhat agree", 2,
                  ifelse(x == "Somewhat disagree", 3, 4)))
  })%>%
  # Reverse items
  mutate_at(vars("UPPS_3", "UPPS_6", "UPPS_8", "UPPS_9", "UPPS_10", "UPPS_13", "UPPS_14", "UPPS_15", "UPPS_16", "UPPS_17", "UPPS_18", "UPPS_20"), reverse, mini = 1, maxi = 4) %>% 
  # Compute scores
  mutate(
    UPPS_NegativeUrgency = (UPPS_6 + UPPS_8 + UPPS_13 + UPPS_15)/4,
    UPPS_PositiveUrgency = (UPPS_3 + UPPS_10 + UPPS_17 + UPPS_20)/4,
    UPPS_LackOfPerseverance = (UPPS_1 + UPPS_4 + UPPS_7 + UPPS_11)/4,
    UPPS_LackOfPremeditation = (UPPS_2 + UPPS_5 + UPPS_12 + UPPS_19)/4,
    UPPS_SensationSeeking = (UPPS_9 + UPPS_14 + UPPS_16 + UPPS_18)/4,
    UPPS_General = (UPPS_NegativeUrgency + UPPS_PositiveUrgency + UPPS_LackOfPerseverance + UPPS_LackOfPremeditation + UPPS_SensationSeeking)/5
) %>% 
  # Remove individual questions
  select(-matches("UPPS_\\d"))

Emotion Regulation (DERS)

df_raw <- df_raw %>%
  # Transform to numeric
  mutate_at(vars(starts_with("DERS")), function(x) {
    ifelse(x == "Almost never (0 - 10%)", 1,
           ifelse(x == "Sometimes (11 - 35%)", 2,
                  ifelse(x == "About half the time (36 - 65%)", 3,
                         ifelse(x == "Most of the time (66 - 90%)", 4, 5))))
  }) %>%
  # Reverse items
  mutate_at(vars("DERS_1", "DERS_4", "DERS_6"), reverse, mini = 1, maxi = 5) %>% 
  # Compute scores
  mutate(
    DERS_Awareness = DERS_1 + DERS_4 + DERS_6,
    DERS_Clarity = DERS_2 + DERS_3 + DERS_5,
    DERS_Goals = DERS_8 + DERS_12 + DERS_15,
    DERS_Impulse = DERS_9 + DERS_16 + DERS_18,
    DERS_NonAcceptance = DERS_7 + DERS_13 + DERS_14,
    DERS_Strategies = DERS_10 + DERS_11 + DERS_17,
    DERS_General = (DERS_Awareness + DERS_Clarity + DERS_Goals + DERS_Impulse + DERS_NonAcceptance + DERS_Strategies) / 6
  ) %>% 
  # Remove individual questions
  select(-matches("DERS_\\d"))

Light Triad (LTS)

df_raw <- df_raw %>%
   # Transform to numeric
  mutate_at(vars(starts_with("LTS")), function(x) {
    ifelse(x == "Agree strongly", 1,
           ifelse(x == "Agree", 2,
                  ifelse(x == "Neutral", 3,
                         ifelse(x == "Disagree", 4, 5)))) 
    })%>%
  # Compute scores
  mutate(
    LTS_FaithInHumanity = (LTS_1 + LTS_4 + LTS_7 + LTS_10)/4,
    LTS_Humanism = (LTS_2 + LTS_5 + LTS_8 + LTS_11)/4,
    LTS_Kantianism = (LTS_3 + LTS_6 + LTS_9 + LTS_12)/4,
    LTS_General = (LTS_FaithInHumanity + LTS_Humanism + LTS_Kantianism)/3
) %>% 
  # Remove individual questions
  select(-matches("LTS_\\d"))

Introception (MAIA2)

df_raw <- df_raw %>%
  # Compute scores
  mutate(
   MAIA2_Noticing = (MAIA2_1 + MAIA2_2 + MAIA2_3 + MAIA2_4)/4,
   MAIA2_BodyListening = (MAIA2_5 + MAIA2_6 + MAIA2_7 + MAIA2_8 + MAIA2_9 + MAIA2_10 + MAIA2_11)/7
) %>% 
  # Remove individual questions
  select(-matches("MAIA2_\\d"))

Data Exclusion

Incomplete Data

df_incomplete <- df_raw %>% 
  filter_at(vars(matches("IPIP6|PID5|BIDR|MAIA|DERS|UPPS|FFNI|LTS|TRIMP|LIE_")), complete.cases) %>% 
  filter(Sex %in% c("Female", "Male")) %>% 
  droplevels()

paste("We excluded", nrow(df_raw) - nrow(df_incomplete), "participants with missing data.")
> [1] "We excluded 5 participants with missing data."

Time to complete

df_time <- df_incomplete %>% 
  mutate(Duration = Duration / 60) %>%  # Express in minutes
  filter(Duration < 120)

# Compute highest density intervals
ci <- bayestestR::eti(df_time$Duration, ci = c(0.8, 0.9, 0.95, 0.99))
cat(paste0("Duration Intervals:\n", paste0("  - ", insight::format_ci(ci$CI_low, ci$CI_high, ci$CI / 100), collapse = "\n")))
> Duration Intervals:
>   - 80% CI [13.09, 42.75]
>   - 90% CI [10.95, 61.94]
>   - 95% CI [9.42, 76.05]
>   - 99% CI [7.52, 96.32]
upper_limit <- ci[ci$CI == 90, "CI_high"]
lower_limit <- ci[ci$CI == 90, "CI_low"]

# Visualisation
ci %>% 
  plot(show_zero = FALSE, show_title = FALSE) +
  geom_vline(xintercept = c(upper_limit, lower_limit), color="red", linetype="dotted") +
  theme_modern() +
  scale_fill_viridis_d() +
  ylab("Distribution") +
  xlab("Time to complete (in minutes)") 

df_time <- df_time %>% 
  filter(Duration < upper_limit,
         Duration > lower_limit)

paste("We excluded", nrow(df_incomplete) - nrow(df_time), "participants with a completion time outside the 90% percentile (>", insight::format_value(lower_limit), "min and <", insight::format_value(upper_limit), "min).")
> [1] "We excluded 141 participants with a completion time outside the 90% percentile (> 10.95 min and < 61.94 min)."

Multivariate outliers

methods <- c("zscore", "iqr", "mahalanobis", "robust", "mcd", "ics", "iforest", "lof")
 
# outliers <- df_time %>%
#   select(matches("LIE_|BIDR|IPIP6|PID5|TRIMP|FFNI|UPPS|DERS|LTS|MAIA"), -matches("_Profile|_General|_Pathology|Disinhibition_|Meanness_|Boldness_")) %>%
#   select(matches("LIE_")) %>%
#   effectsize::standardize() %>%
#   performance::check_outliers(method = methods)

# Visualise
# as.data.frame(outliers) %>%
#   mutate(Outlier = as.factor(paste0(round(Outlier*8), "/", length(methods)))) %>%
#   ggplot(aes(x = Outlier, fill = Outlier)) +
#   geom_bar() +
#   geom_vline(aes(xintercept = 6.5), color = "red", linetype = "dotted") +
#   theme_modern() +
#   see::scale_fill_metro_d(guide = FALSE) +
#   xlab("Proportion of methods aggreeing on an outlier") +
#   ylab("Number of participants")

# save(outliers, file="outliers.Rdata")
load("outliers.Rdata")

df <- df_time[-which(as.numeric(outliers) >= 6/length(methods)), ]

paste("Based on a composite outlier score (see the 'check_outliers' function in the 'performance' R package; Lüdecke et al., 2019) obtained via the joint application of multiple outliers detection algorithms (Z-scores, Iglewicz, 1993; Interquartile range (IQR); Mahalanobis distance, Cabana, 2019; Robust Mahalanobis distance, Gnanadesikan & Kettenring, 1972; Minimum Covariance Determinant, Leys et al., 2018; Invariant Coordinate Selection, Archimbaud et al., 2018; Isolation Forest, Liu et al. 2008; and Local Outlier Factor, Breunig et al., 2000), we excluded", nrow(df_time) - nrow(df), "participants that were classified as outliers by at least 6/8 of the methods used.")
> [1] "Based on a composite outlier score (see the 'check_outliers' function in the 'performance' R package; Lüdecke et al., 2019) obtained via the joint application of multiple outliers detection algorithms (Z-scores, Iglewicz, 1993; Interquartile range (IQR); Mahalanobis distance, Cabana, 2019; Robust Mahalanobis distance, Gnanadesikan & Kettenring, 1972; Minimum Covariance Determinant, Leys et al., 2018; Invariant Coordinate Selection, Archimbaud et al., 2018; Isolation Forest, Liu et al. 2008; and Local Outlier Factor, Breunig et al., 2000), we excluded 103 participants that were classified as outliers by at least 6/8 of the methods used."

Final Sample

paste("The final sample included", report_participants(df))
> [1] "The final sample included 762 participants (Mean age = 25.4, SD = 7.8, range: [19.0, 73.51]; 56.0% females; Mean education = 3.5, SD = 2.0, range: [-7, 10])"
df <- df %>% 
  mutate(System_Screen = sqrt(System_Screen),
         Education_Student = as.factor(ifelse(Education_Student == "", NA, Education_Student)),
         Religion_Type = ifelse(Religion_Type == "", NA, Religion_Type), 
         Singapore_Duration = ifelse(Singapore_Duration > Age, NA, Singapore_Duration),
         Singapore_Duration = Singapore_Duration / Age)

df %>% 
  select(System_Device, System_Screen, Duration, Education_Student, Education_Type, Ethnicity, starts_with("Religion"), Income, Singapore_Duration) %>% 
  report(levels_percentage = TRUE, missing_percentage = TRUE, n_entries = 10)
> The data contains 762 observations of the following variables:
>   - System_Device: 3 entries, such as Phone (74.15%%); Computer (25.07%%); Tablet (0.79%%); NA; NA; NA; NA; NA; NA; NA(0.00% missing)
>   - System_Screen: n = 762, Mean = 692.93, SD = 265.01, Median = 552.00, MAD = 76.91, range: [426.33, 2225.67], Skewness = 1.50, Kurtosis = 1.63, 0% missing
>   - Duration: n = 762, Mean = 23.90, SD = 9.69, Median = 21.23, MAD = 7.12, range: [10.97, 61.70], Skewness = 1.42, Kurtosis = 2.04, 0% missing
>   - Education_Student: 2 levels, namely No (n = 229, 30.05%), Yes (n = 532, 69.82%) and missing (n = 1, 0.13%)
>   - Education_Type: 18 entries, such as Business and Accountancy (22.31%%); Engineering (19.29%%); Social Sciences (Psychology, Sociology, etc.) (15.88%%); Sciences (10.89%%); Others (7.22%%); Computing (5.77%%); Humanities (Languages, History, etc.) (4.99%%); Communication Studies (3.28%%); Medicine (3.02%%); Art and Design (1.97%%) and 8 others(0.00% missing)
>   - Ethnicity: 20 entries, such as Chinese (87.80%%); Malay (4.33%%); Indian (3.41%%);  (1.84%%); Vietnamese (0.39%%); Eurasian (0.26%%); Korean (0.26%%); African (0.13%%); Arabic (0.13%%); Boyanese  (0.13%%) and 10 others(0.00% missing)
>   - Religion_Type: 6 entries, such as Buddhism (33.33%%); No religion (25.46%%); Christianity (24.80%%); Taoism (5.77%%); Islam (4.99%%); Hinduism (2.36%%); NA; NA; NA; NA(3.28% missing)
>   - Religion_Religiosity: n = 762, Mean = 4.22, SD = 2.97, Median = , MAD = 4.45, range: [0, 10], Skewness = 0.06, Kurtosis = -1.26, 2.89% missing
>   - Religion_Engagement: n = 762, Mean = 3.82, SD = 3.09, Median = , MAD = 4.45, range: [0, 10], Skewness = 0.30, Kurtosis = -1.18, 3.54% missing
>   - Income: n = 762, Mean = 2802.21, SD = 4348.98, Median = , MAD = 1482.60, range: [0, 60000], Skewness = 8.46, Kurtosis = 96.78, 13.25% missing
>   - Singapore_Duration: n = 762, Mean = 0.88, SD = 0.25, Median = , MAD = 0.02, range: [0, 1.00], Skewness = -2.51, Kurtosis = 4.85, 24.41% missing
df <- df %>% 
  mutate(Education_Type = ifelse(!Education_Type %in% c("Business and Accountancy",
                                                        "Engineering",
                                                        "Social Sciences (Psychology, Sociology...)",
                                                        "Sciences",
                                                        "Computing",
                                                        "Humanities (Languages, History...)"), "Other", Education_Type),
         Ethnicity = ifelse(!Ethnicity %in% c("Chinese", "Malay", "Indian"), "Other", Ethnicity))

Education and Income

report_participants(df, group = c("Sex", "Education_Student"))
> [1] "For the 'Sex - Female and Education_Student - No' group: 136 participants (Mean age = 31.3, SD = 11.7, range: [21.7, 73.51]; 100.0% females; Mean education = 2.8, SD = 2.7, range: [-7, 6]), for the 'Sex - Male and Education_Student - No' group: 93 participants (Mean age = 30.9, SD = 11.9, range: [19.7, 66.19]; 0.0% females; Mean education = 2.1, SD = 2.8, range: [-6, 10]), for the 'Sex - Female and Education_Student - Yes' group: 291 participants (Mean age = 22.7, SD = 3.0, range: [19.1, 56.25]; 100.0% females; Mean education = 4.0, SD = 1.5, range: [0, 10]) and for the 'Sex - Male and Education_Student - Yes' group: 241 participants (Mean age = 23.3, SD = 2.1, range: [19.0, 39.79]; 0.0% females; Mean education = 3.9, SD = 1.3, range: [-2, 10])"
as.data.frame(table(df$Education_Type)) %>%
  ggplot(aes(x="", y =Freq, fill = reorder(Var1, -Freq))) +
  geom_bar(width = 1, stat = "identity") +
  labs(fill = "Course") +
  coord_polar("y", start = 0, direction = -1) +
  scale_fill_brewer(palette="Blues") +
  theme_void() +
  theme(legend.text = element_text(size = 20)) +
  theme(legend.title = element_text(face = "bold", size = 20))

df %>% 
  filter(!is.na(Education_Student)) %>% 
  filter(Income < 18000) %>% 
  ggplot(aes(x = Income, colour = Education_Type)) +
  geom_density(size = 1) +
  facet_grid(~Education_Student, labeller = "label_both") +
  theme_modern()

df %>% 
  filter(!is.na(Education_Student)) %>% 
  filter(Income < 18000) %>% 
  ggplot(aes(x = Age, y = Income, colour = Education_Type, fill = Education_Type)) +
  geom_point2() +
  geom_smooth(method = "lm", alpha = 0.1) + 
  theme_modern()

Culture

as.data.frame(table(df$Ethnicity)) %>%
  ggplot(aes(x="", y = Freq, fill = reorder(Var1, -Freq))) +
  labs(fill = "Ethnicity") +
  geom_bar(width = 1, stat = "identity") +
  coord_polar("y", start = 0) +
  scale_fill_brewer(palette="Oranges") +
  theme_void() +
  theme(legend.text = element_text(size = 20)) +
  theme(legend.title = element_text(face = "bold", size = 20))

df %>% 
  filter(!is.na(Singapore_Duration)) %>% 
  ggplot(aes(x = Singapore_Duration, colour = Ethnicity)) +
  geom_density(size = 1) +
  theme_modern() +
  scale_x_continuous(labels = scales::percent)

Religion

as.data.frame(table(df$Religion_Type)) %>%
  ggplot(aes(x="", y = Freq, fill = reorder(Var1, -Freq))) +
  geom_bar(width = 1, stat = "identity") +
  labs(fill = "Religion") +
  coord_polar("y", start = 0) +
  scale_fill_brewer(palette="Purples") +
  theme_void() +
  theme(legend.text = element_text(size = 20)) +
  theme(legend.title = element_text(face = "bold", size = 20))

df %>% 
  filter(!is.na(Religion_Engagement)) %>% 
  filter(!is.na(Religion_Type)) %>% 
  ggplot(aes(x = Religion_Engagement, colour = Religion_Type)) +
  geom_density(size = 1) +
  theme_modern()

df %>% 
  filter(!is.na(Religion_Religiosity)) %>% 
  filter(!is.na(Religion_Type)) %>% 
  ggplot(aes(x = Religion_Religiosity, colour = Religion_Type)) +
  geom_density(size = 1) +
  theme_modern()

df %>% 
  filter(!is.na(Religion_Engagement)) %>% 
  filter(!is.na(Religion_Religiosity)) %>% 
  filter(!is.na(Religion_Type)) %>% 
  ggplot(aes(x = Religion_Religiosity, y = Religion_Engagement, colour = Religion_Type, fill = Religion_Type)) +
  geom_jitter() +
  geom_smooth(method = "lm", alpha = 0.2) +
  ggtitle(paste("r =", insight::format_value(cor.test(df$Religion_Engagement, df$Religion_Religiosity)$estimate))) +
  theme_modern()

df <- df %>% 
  mutate(Religion_Faith = (Religion_Engagement + Religion_Religiosity) / 2)

Results

Descriptive Statistics

Deception and Lying Profile (LIE)

descriptive_statistics(df, "LIE_")
> Variable |  Mean |   SD |   Min |  Max | Skewness | Kurtosis | percentage_Missing
> ---------------------------------------------------------------------------------
> LIE_1    | -1.78 | 2.41 | -5.00 | 5.00 |     0.49 |    -0.66 |               0.00
> LIE_2    | -1.40 | 2.54 | -5.00 | 5.00 |     0.37 |    -0.82 |               0.00
> LIE_3    | -2.44 | 2.64 | -5.00 | 5.00 |     1.03 |     0.21 |               0.00
> LIE_4    | -1.61 | 2.46 | -5.00 | 5.00 |     0.40 |    -0.72 |               0.00
> LIE_5    | -1.84 | 2.29 | -5.00 | 5.00 |     0.49 |    -0.58 |               0.00
> LIE_6    | -1.00 | 2.58 | -5.00 | 5.00 |     0.17 |    -1.01 |               0.00
> LIE_7    | -0.78 | 2.70 | -5.00 | 5.00 |     0.17 |    -0.97 |               0.00
> LIE_8    | -1.37 | 2.29 | -5.00 | 5.00 |     0.41 |    -0.43 |               0.00
> LIE_9    | -0.20 | 2.74 | -5.00 | 5.00 |    -0.15 |    -0.98 |               0.00
> LIE_10   |  0.13 | 2.72 | -5.00 | 5.00 |    -0.27 |    -0.88 |               0.00
> LIE_11   | -0.37 | 2.62 | -5.00 | 5.00 |    -0.04 |    -0.91 |               0.00
> LIE_12   |  0.77 | 2.64 | -5.00 | 5.00 |    -0.56 |    -0.52 |               0.00
> LIE_13   | -0.46 | 2.56 | -5.00 | 5.00 |     0.25 |    -0.68 |               0.00
> LIE_14   |  0.42 | 2.46 | -5.00 | 5.00 |    -0.38 |    -0.58 |               0.00
> LIE_15   |  0.16 | 2.61 | -5.00 | 5.00 |    -0.15 |    -0.83 |               0.00
> LIE_16   | -1.00 | 2.39 | -5.00 | 5.00 |     0.38 |    -0.41 |               0.00
> LIE_17   |  0.56 | 2.71 | -5.00 | 5.00 |    -0.07 |    -0.97 |               0.00
> LIE_18   | -0.02 | 2.67 | -5.00 | 5.00 |    -0.23 |    -0.93 |               0.00
> LIE_19   |  1.02 | 2.64 | -5.00 | 5.00 |    -0.35 |    -0.83 |               0.00
> LIE_20   | -0.18 | 2.61 | -5.00 | 5.00 |    -0.06 |    -0.86 |               0.00
> LIE_21   | -1.01 | 2.75 | -5.00 | 5.00 |     0.36 |    -0.84 |               0.00
> LIE_22   | -2.26 | 2.35 | -5.00 | 5.00 |     0.67 |    -0.43 |               0.00
> LIE_23   | -1.87 | 2.37 | -5.00 | 5.00 |     0.61 |    -0.38 |               0.00
> LIE_24   |  1.24 | 2.36 | -5.00 | 5.00 |    -0.39 |    -0.48 |               0.00
> LIE_25   |  1.73 | 2.41 | -5.00 | 5.00 |    -0.62 |    -0.22 |               0.00
> LIE_26   | -2.61 | 2.20 | -5.00 | 5.00 |     0.89 |     0.15 |               0.00
> LIE_27   |  1.15 | 2.58 | -5.00 | 5.00 |    -0.40 |    -0.70 |               0.00
> LIE_28   | -0.26 | 2.56 | -5.00 | 5.00 |    -0.10 |    -0.76 |               0.00
> LIE_29   | -0.96 | 2.69 | -5.00 | 5.00 |     0.28 |    -0.91 |               0.00
> LIE_30   |  0.39 | 2.69 | -5.00 | 5.00 |    -0.33 |    -0.84 |               0.00
> LIE_31   | -0.42 | 2.62 | -5.00 | 5.00 |    -0.04 |    -0.96 |               0.00
> LIE_32   |  0.53 | 2.67 | -5.00 | 5.00 |    -0.37 |    -0.74 |               0.00
> LIE_33   |  1.84 | 2.18 | -5.00 | 5.00 |    -1.05 |     1.33 |               0.00
> LIE_34   |  2.64 | 2.00 | -5.00 | 5.00 |    -0.76 |     0.31 |               0.00
> LIE_35   |  1.73 | 2.31 | -5.00 | 5.00 |    -0.59 |    -0.14 |               0.00
> LIE_36   |  1.02 | 2.41 | -5.00 | 5.00 |    -0.25 |    -0.65 |               0.00
> LIE_37   |  0.56 | 2.73 | -5.00 | 5.00 |    -0.01 |    -0.97 |               0.00
> LIE_38   |  1.81 | 2.51 | -5.00 | 5.00 |    -0.55 |    -0.60 |               0.00
> LIE_39   |  1.69 | 2.46 | -5.00 | 5.00 |    -0.87 |     0.30 |               0.00
> LIE_40   |  1.80 | 2.42 | -5.00 | 5.00 |    -0.73 |     0.06 |               0.00
> LIE_41   |  0.99 | 2.65 | -5.00 | 5.00 |    -0.19 |    -0.83 |               0.00
> LIE_42   |  1.87 | 2.22 | -5.00 | 5.00 |    -0.76 |     0.58 |               0.00
> LIE_43   |  1.78 | 2.28 | -5.00 | 5.00 |    -0.99 |     0.98 |               0.00
> LIE_44   |  2.05 | 2.39 | -5.00 | 5.00 |    -0.67 |    -0.14 |               0.00

Psychopathy (TRIMP)

df %>% 
  select(TRIMP_General, starts_with("TRIMP_Boldness"), starts_with("TRIMP_Meanness"), starts_with("TRIMP_Disinhibition")) %>% 
  report() %>% 
  as.data.frame() %>% 
  select(-one_of(c("n_Obs", "Median", "MAD", "n_Missing"))) %>% 
  print()
> Variable                                   | Mean |   SD |  Min |  Max |  Skewness |  Kurtosis | percentage_Missing
> -------------------------------------------------------------------------------------------------------------------
> TRIMP_General                              | 1.08 | 0.28 | 0.34 | 1.90 |      0.25 |     -0.30 |               0.00
> TRIMP_Boldness                             | 1.43 | 0.37 | 0.26 | 2.37 |     -0.15 | -5.46e-03 |               0.00
> TRIMP_Boldness_Optimism                    | 1.72 | 0.56 | 0.00 | 3.00 |     -0.31 |      0.20 |               0.00
> TRIMP_Boldness_Resilience                  | 1.55 | 0.63 | 0.00 | 3.00 |     -0.13 |     -0.28 |               0.00
> TRIMP_Boldness_Courage                     | 1.36 | 0.67 | 0.00 | 3.00 |      0.08 |     -0.06 |               0.00
> TRIMP_Boldness_Dominance                   | 1.39 | 0.70 | 0.00 | 3.00 |     -0.02 |     -0.30 |               0.00
> TRIMP_Boldness_Persuasiveness              | 1.53 | 0.59 | 0.00 | 3.00 |     -0.18 |     -0.18 |               0.00
> TRIMP_Boldness_Intrepidness                | 1.06 | 0.73 | 0.00 | 3.00 |      0.32 |     -0.59 |               0.00
> TRIMP_Boldness_ToleranceForUncertainty     | 1.32 | 0.60 | 0.00 | 3.00 |      0.09 |      0.26 |               0.00
> TRIMP_Boldness_SelfConfidence              | 1.58 | 0.66 | 0.00 | 3.00 |      0.11 |     -0.35 |               0.00
> TRIMP_Boldness_SocialAssurance             | 1.31 | 0.65 | 0.00 | 3.00 |      0.06 |     -0.09 |               0.00
> TRIMP_Meanness                             | 0.88 | 0.40 | 0.00 | 2.05 |      0.24 |     -0.44 |               0.00
> TRIMP_Meanness_Empathy                     | 0.80 | 0.45 | 0.00 | 2.10 |      0.23 |     -0.64 |               0.00
> TRIMP_Meanness_ExcitementSeeking           | 1.30 | 0.79 | 0.00 | 3.00 |      0.02 |     -0.68 |               0.00
> TRIMP_Meanness_PhysicalAggression          | 0.88 | 0.92 | 0.00 | 3.00 |      0.61 |     -0.77 |               0.00
> TRIMP_Meanness_RelationalAggression        | 1.02 | 0.63 | 0.00 | 2.75 |      0.23 |     -0.62 |               0.00
> TRIMP_Meanness_Honesty                     | 0.79 | 0.69 | 0.00 | 3.00 |      0.61 |      0.33 |               0.00
> TRIMP_Meanness_DestructiveAggression       | 0.35 | 0.63 | 0.00 | 3.00 |      1.70 |      1.96 |               0.00
> TRIMP_Disinhibition                        | 0.93 | 0.40 | 0.05 | 2.30 |      0.44 |     -0.08 |               0.00
> TRIMP_Disinhibition_ImpatienceUrgency      | 1.74 | 0.59 | 0.00 | 3.00 |     -0.30 |      0.11 |               0.00
> TRIMP_Disinhibition_Dependability          | 0.92 | 0.65 | 0.00 | 3.00 |      0.25 |     -0.46 |               0.00
> TRIMP_Disinhibition_ProblematicImpulsivity | 1.11 | 0.63 | 0.00 | 2.75 |      0.03 |     -0.66 |               0.00
> TRIMP_Disinhibition_Irresponsibility       | 0.65 | 0.60 | 0.00 | 2.50 |      0.77 |     -0.25 |               0.00
> TRIMP_Disinhibition_PlanfulControl         | 1.09 | 0.64 | 0.00 | 3.00 |      0.45 |      0.74 |               0.00
> TRIMP_Disinhibition_Theft                  | 0.39 | 0.52 | 0.00 | 2.50 |      1.49 |      1.72 |               0.00
> TRIMP_Disinhibition_Alienation             | 1.45 | 0.87 | 0.00 | 3.00 | -2.16e-03 |     -0.67 |               0.00
> TRIMP_Disinhibition_BoredomProneness       | 1.70 | 0.81 | 0.00 | 3.00 |     -0.22 |     -0.40 |               0.00
> TRIMP_Disinhibition_Fraud                  | 0.40 | 0.69 | 0.00 | 3.00 |      1.64 |      1.89 |               0.00
plots(
  df %>% 
    select(starts_with("TRIMP_Boldness")) %>% 
    bayestestR::estimate_density(method = "KernSmooth") %>% 
    plot() + 
    theme_modern(),
  df %>% 
    select(starts_with("TRIMP_Meanness")) %>% 
    bayestestR::estimate_density(method = "KernSmooth") %>% 
    plot() + 
    theme_modern(),
  df %>% 
    select(starts_with("TRIMP_Disinhibition")) %>% 
    bayestestR::estimate_density(method = "KernSmooth") %>% 
    plot() + 
    theme_modern()
    )

Narcissism (FFNI)

descriptive_statistics(df, "FFNI")
> Variable               |  Mean |   SD |  Min |   Max | Skewness | Kurtosis | percentage_Missing
> -----------------------------------------------------------------------------------------------
> FFNI_AcclaimSeeking    | 14.19 | 3.33 | 4.00 | 20.00 |    -0.62 |     0.41 |               0.00
> FFNI_Distrust          | 12.27 | 2.83 | 4.00 | 20.00 |    -0.04 |    -0.02 |               0.00
> FFNI_Entitlement       |  9.94 | 3.63 | 4.00 | 20.00 |     0.14 |    -0.77 |               0.00
> FFNI_Exploitativeness  |  9.01 | 3.67 | 4.00 | 20.00 |     0.34 |    -0.80 |               0.00
> FFNI_Indifference      | 11.03 | 3.75 | 4.00 | 20.00 |     0.22 |    -0.63 |               0.00
> FFNI_LackOfEmpathy     |  9.19 | 3.14 | 4.00 | 20.00 |     0.42 |    -0.38 |               0.00
> FFNI_Manipulativeness  | 10.31 | 3.66 | 4.00 | 20.00 |     0.13 |    -0.78 |               0.00
> FFNI_NeedForAdmiration | 12.87 | 2.89 | 4.00 | 20.00 |    -0.39 |     0.18 |               0.00
> FFNI_ThrillSeeking     | 10.56 | 3.75 | 4.00 | 20.00 |     0.07 |    -0.78 |               0.00
> FFNI_General           | 11.04 | 1.95 | 5.89 | 19.44 |     0.19 |     0.32 |               0.00

Normal Personality (IPIP6)

descriptive_statistics(df, "IPIP6")
> Variable                | Mean |   SD |  Min |  Max | Skewness |  Kurtosis | percentage_Missing
> -----------------------------------------------------------------------------------------------
> IPIP6_Extraversion      | 3.58 | 1.20 | 1.00 | 6.75 |     0.13 |     -0.56 |               0.00
> IPIP6_Agreableness      | 4.99 | 0.90 | 1.25 | 7.00 |    -0.29 |      0.11 |               0.00
> IPIP6_Conscientiousness | 4.48 | 1.07 | 1.00 | 7.00 |    -0.24 | -3.94e-03 |               0.00
> IPIP6_Neuroticism       | 3.91 | 1.09 | 1.00 | 7.00 |    -0.02 |     -0.21 |               0.00
> IPIP6_Openness          | 4.53 | 1.05 | 1.50 | 7.00 |    -0.10 |     -0.38 |               0.00
> IPIP6_HonestyHumility   | 4.39 | 1.24 | 1.25 | 7.00 |    -0.04 |     -0.60 |               0.00

Pathological Personality (PID-5)

descriptive_statistics(df, "PID5")
> Variable            | Mean |   SD |  Min |  Max | Skewness | Kurtosis | percentage_Missing
> ------------------------------------------------------------------------------------------
> PID5_NegativeAffect | 1.40 | 0.63 | 0.00 | 3.00 |    -0.13 |    -0.36 |               0.00
> PID5_Detachment     | 1.08 | 0.55 | 0.00 | 3.00 |     0.10 |    -0.17 |               0.00
> PID5_Antagonism     | 0.89 | 0.54 | 0.00 | 3.00 |     0.38 |    -0.10 |               0.00
> PID5_Disinhibition  | 0.97 | 0.63 | 0.00 | 3.00 |     0.15 |    -0.77 |               0.00
> PID5_Psychoticism   | 1.24 | 0.60 | 0.00 | 3.00 |    -0.09 |    -0.31 |               0.00
> PID5_Pathology      | 1.12 | 0.45 | 0.00 | 3.00 |    -0.02 |     0.12 |               0.00

Social Desirability (BIDR)

descriptive_statistics(df, "BIDR")
> Variable                      | Mean |   SD |  Min |  Max | Skewness | Kurtosis | percentage_Missing
> ----------------------------------------------------------------------------------------------------
> BIDR_SelfDeceptiveEnhancement | 3.90 | 0.80 | 1.50 | 7.00 |     0.09 |     0.45 |               0.00
> BIDR_ImpressionManagement     | 3.82 | 0.81 | 1.12 | 6.62 |     0.21 |     0.51 |               0.00
> BIDR_General                  | 3.86 | 0.65 | 1.44 | 6.56 |     0.31 |     1.09 |               0.00

Impulsivity (UPPS)

descriptive_statistics(df, "UPPS")
> Variable                 | Mean |   SD |  Min |  Max | Skewness | Kurtosis | percentage_Missing
> -----------------------------------------------------------------------------------------------
> UPPS_NegativeUrgency     | 2.39 | 0.62 | 1.00 | 4.00 |    -0.22 |    -0.34 |               0.00
> UPPS_PositiveUrgency     | 2.13 | 0.61 | 1.00 | 3.75 |    -0.09 |    -0.61 |               0.00
> UPPS_LackOfPerseverance  | 1.85 | 0.44 | 1.00 | 3.25 |    -0.02 |    -0.14 |               0.00
> UPPS_LackOfPremeditation | 1.87 | 0.44 | 1.00 | 3.75 |    -0.06 |     0.34 |               0.00
> UPPS_SensationSeeking    | 2.68 | 0.65 | 1.00 | 4.00 |    -0.24 |    -0.26 |               0.00
> UPPS_General             | 2.18 | 0.34 | 1.10 | 3.00 |    -0.40 |    -0.17 |               0.00

Emotion Regulation (DERS)

descriptive_statistics(df, "DERS")
> Variable           | Mean |   SD |  Min |   Max | Skewness | Kurtosis | percentage_Missing
> ------------------------------------------------------------------------------------------
> DERS_Awareness     | 7.04 | 2.01 | 3.00 | 13.00 |     0.33 |    -0.18 |               0.00
> DERS_Clarity       | 7.42 | 2.46 | 3.00 | 15.00 |     0.44 |    -0.18 |               0.00
> DERS_Goals         | 9.36 | 3.16 | 3.00 | 15.00 | 7.17e-04 |    -0.94 |               0.00
> DERS_Impulse       | 6.76 | 2.96 | 3.00 | 15.00 |     0.58 |    -0.48 |               0.00
> DERS_NonAcceptance | 7.32 | 3.04 | 3.00 | 15.00 |     0.49 |    -0.55 |               0.00
> DERS_Strategies    | 6.92 | 2.99 | 3.00 | 15.00 |     0.55 |    -0.56 |               0.00
> DERS_General       | 7.47 | 1.96 | 3.00 | 13.00 |     0.26 |    -0.57 |               0.00

Light Triad (LTS)

descriptive_statistics(df, "LTS")
> Variable            | Mean |   SD |  Min |  Max | Skewness | Kurtosis | percentage_Missing
> ------------------------------------------------------------------------------------------
> LTS_FaithInHumanity | 2.38 | 0.62 | 1.00 | 4.50 |     0.54 |     0.54 |               0.00
> LTS_Humanism        | 2.04 | 0.49 | 1.00 | 4.00 |     0.28 |     0.47 |               0.00
> LTS_Kantianism      | 2.08 | 0.56 | 1.00 | 4.00 |     0.35 |     0.16 |               0.00
> LTS_General         | 2.16 | 0.44 | 1.00 | 4.00 |     0.24 |     0.50 |               0.00

Interoception (MAIA2)

descriptive_statistics(df, "MAIA2")
> Variable            | Mean |   SD |  Min |  Max | Skewness | Kurtosis | percentage_Missing
> ------------------------------------------------------------------------------------------
> MAIA2_Noticing      | 3.15 | 0.85 | 0.00 | 5.00 |    -0.44 |     0.22 |               0.00
> MAIA2_BodyListening | 2.82 | 0.89 | 0.00 | 5.00 |    -0.40 |    -0.06 |               0.00

Factor Structure

Splitting the data 50-50 for EFA-CFA

lie <- select(df, starts_with("LIE_"))
labels_lie <- labels[labels$Questionnaire == "LIE", ]

# Two sets of data 50-50
partitions <- parameters::data_partition(lie, training_proportion = 0.6)
lie_EFA <- partitions$training
lie_CFA <- partitions$test


# Compare stats across groups
group_indices = c(rep(2, round(nrow(lie)/2)), rep(1, nrow(lie) - round(nrow(lie)/2)))
lie_grouped <- cbind(lie, group_indices) 

psych::statsBy(lie_grouped, group = "group_indices")
> Statistics within and between groups  
> Call: psych::statsBy(data = lie_grouped, group = "group_indices")
> Intraclass Correlation 1 (Percentage of variance due to groups) 
>         LIE_1         LIE_2         LIE_3         LIE_4         LIE_5 
>          0.00          0.00          0.00          0.00          0.03 
>         LIE_6         LIE_7         LIE_8         LIE_9        LIE_10 
>          0.01          0.00          0.00          0.00          0.00 
>        LIE_11        LIE_12        LIE_13        LIE_14        LIE_15 
>          0.00          0.00          0.00          0.00          0.00 
>        LIE_16        LIE_17        LIE_18        LIE_19        LIE_20 
>          0.00          0.00          0.00          0.00          0.00 
>        LIE_21        LIE_22        LIE_23        LIE_24        LIE_25 
>          0.00          0.00          0.00          0.00          0.00 
>        LIE_26        LIE_27        LIE_28        LIE_29        LIE_30 
>          0.00          0.00          0.00          0.00          0.00 
>        LIE_31        LIE_32        LIE_33        LIE_34        LIE_35 
>          0.00          0.00          0.00          0.00          0.00 
>        LIE_36        LIE_37        LIE_38        LIE_39        LIE_40 
>          0.02          0.01          0.01          0.00          0.00 
>        LIE_41        LIE_42        LIE_43        LIE_44 group_indices 
>          0.01          0.00          0.00          0.00          1.00 
> Intraclass Correlation 2 (Reliability of group differences) 
>         LIE_1         LIE_2         LIE_3         LIE_4         LIE_5 
>       5.0e-02      -7.0e+01      -4.9e+01      -1.3e+00       9.2e-01 
>         LIE_6         LIE_7         LIE_8         LIE_9        LIE_10 
>       7.1e-01       3.9e-01      -3.0e-01      -8.0e+00      -5.6e+05 
>        LIE_11        LIE_12        LIE_13        LIE_14        LIE_15 
>      -4.1e+01      -1.1e+02      -2.2e+01      -7.8e+00       0.0e+00 
>        LIE_16        LIE_17        LIE_18        LIE_19        LIE_20 
>       2.3e-01      -1.1e+00      -2.0e+01       3.5e-01       2.4e-01 
>        LIE_21        LIE_22        LIE_23        LIE_24        LIE_25 
>      -4.6e-01      -4.1e+00       5.0e-01      -4.4e+02       4.4e-01 
>        LIE_26        LIE_27        LIE_28        LIE_29        LIE_30 
>       6.0e-01      -3.1e+01      -8.2e+00       6.4e-01      -1.1e+00 
>        LIE_31        LIE_32        LIE_33        LIE_34        LIE_35 
>      -2.9e+02      -4.9e+01       1.1e-01       3.3e-01       5.5e-01 
>        LIE_36        LIE_37        LIE_38        LIE_39        LIE_40 
>       8.9e-01       7.2e-01       6.8e-01       0.0e+00      -5.4e+00 
>        LIE_41        LIE_42        LIE_43        LIE_44 group_indices 
>       6.8e-01      -6.9e+00      -3.8e+00       4.5e-01       1.0e+00 
> eta^2 between groups  
>  LIE_1.bg  LIE_2.bg  LIE_3.bg  LIE_4.bg  LIE_5.bg  LIE_6.bg  LIE_7.bg  LIE_8.bg 
>      0.00      0.00      0.00      0.00      0.02      0.00      0.00      0.00 
>  LIE_9.bg LIE_10.bg LIE_11.bg LIE_12.bg LIE_13.bg LIE_14.bg LIE_15.bg LIE_16.bg 
>      0.00      0.00      0.00      0.00      0.00      0.00      0.00      0.00 
> LIE_17.bg LIE_18.bg LIE_19.bg LIE_20.bg LIE_21.bg LIE_22.bg LIE_23.bg LIE_24.bg 
>      0.00      0.00      0.00      0.00      0.00      0.00      0.00      0.00 
> LIE_25.bg LIE_26.bg LIE_27.bg LIE_28.bg LIE_29.bg LIE_30.bg LIE_31.bg LIE_32.bg 
>      0.00      0.00      0.00      0.00      0.00      0.00      0.00      0.00 
> LIE_33.bg LIE_34.bg LIE_35.bg LIE_36.bg LIE_37.bg LIE_38.bg LIE_39.bg LIE_40.bg 
>      0.00      0.00      0.00      0.01      0.00      0.00      0.00      0.00 
> LIE_41.bg LIE_42.bg LIE_43.bg LIE_44.bg 
>      0.00      0.00      0.00      0.00 
> 
> To see the correlations between and within groups, use the short=FALSE option in your print statement.
> Many results are not shown directly. To see specific objects select from the following list:
>  mean sd n F ICC1 ICC2 ci1 ci2 raw rbg pbg rwg nw ci.wg pwg etabg etawg nwg nG Call

Factor structure quality

parameters::check_factorstructure(lie_EFA)
> # Is the data suitable for Factor Analysis?
> 
>   - KMO: The Kaiser, Meyer, Olkin (KMO) measure of sampling adequacy suggests that data seems appropriate for factor analysis (KMO = 0.93).
>   - Sphericity: Bartlett's test of sphericity suggests that there is sufficient significant correlation in the data for factor analysis (Chisq(946) = 9653.38, p < .001).

Correlation matrix

cor <- as.matrix(correlation::correlation(lie_EFA))

How many factors

parameters::n_factors(lie_EFA, cor = cor, rotation = "varimax", package = "all", safe = FALSE) %T>% 
  print() %>%
  plot() +
  ggtitle("How many factors to retain (Pearson's correlations)") +
  theme_modern()
> # Method Agreement Procedure:
> 
> The choice of 4 dimensions is supported by 5 (20.00%) methods out of 25 (beta, EGA (TMFG), Velicer's MAP, BIC, BIC).

Exploratory Factor Analysis (EFA)

Four latent factors model

efa_4 <- psych::fa(cor, n.obs = nrow(lie_EFA), nfactors = 4, rotate = "varimax", fm = "ml") 

parameters::model_parameters(efa_4, labels = labels_lie$Description) %>% 
  print(sort = TRUE, threshold = "max") 
> # Rotated loadings from Factor Analysis (varimax-rotation)
> 
> Variable |                                                      Label |   ML2 |   ML1 |  ML4 |   ML3 | Complexity | Uniqueness
> ------------------------------------------------------------------------------------------------------------------------------
> LIE_4    |                                   I have a tendency to lie |  0.75 |       |      |       |       1.23 |       0.38
> LIE_23   |           I find it difficult to refrain myself from lying |  0.73 |       |      |       |       1.13 |       0.44
> LIE_5    |                      I lie more often than most people do  |  0.73 |       |      |       |       1.34 |       0.39
> LIE_1    |                                           I lie frequently |  0.70 |       |      |       |       1.61 |       0.36
> LIE_22   |                     I find myself lying without any reason |  0.68 |       |      |       |       1.11 |       0.51
> LIE_7    |                           I lie more than I think I should |  0.67 |       |      |       |       1.06 |       0.54
> LIE_6    |         I lie more frequently than what I expect myself to |  0.65 |       |      |       |       1.14 |       0.55
> LIE_2    |                                   I lie in many situations |  0.61 |       |      |       |       1.81 |       0.47
> LIE_26   |                                              I enjoy lying |  0.59 |       |      |       |       1.66 |       0.54
> LIE_8    |                            Others lie less often than I do |  0.53 |       |      |       |       1.23 |       0.69
> LIE_29   |                             I lie whenever it’s convenient |  0.49 |       |      |       |       2.10 |       0.64
> LIE_21   |                          I have to try hard to avoid lying |  0.45 |       |      |       |       1.16 |       0.78
> LIE_31   |       I lie if it’s the most direct way to get what I want |  0.44 |       |      |       |       2.15 |       0.69
> LIE_28   |                I feel satisfied when others believe my lie |  0.36 |       |      |       |       2.99 |       0.71
> LIE_24   |                  It is easy to hold back from telling lies | -0.29 |       |      |       |       1.83 |       0.88
> LIE_10   |                                             I can lie well |       |  0.82 |      |       |       1.39 |       0.20
> LIE_9    |                                           I am a good liar |       |  0.75 |      |       |       1.56 |       0.29
> LIE_18   |                   It is easy for me to make up clever lies |       |  0.73 |      |       |       1.38 |       0.37
> LIE_14   |                    It is hard for others to detect my lies |       |  0.73 |      |       |       1.22 |       0.42
> LIE_11   |                              I am good at deceiving others |       |  0.71 |      |       |       1.56 |       0.36
> LIE_13   |                      Others can easily tell when I’m lying |       | -0.69 |      |       |       1.22 |       0.48
> LIE_12   |                         I can lie effectively if I want to |       |  0.67 |      |       |       1.42 |       0.46
> LIE_17   |                                     I find lying difficult |       | -0.67 |      |       |       1.82 |       0.36
> LIE_15   |                            I almost never get caught lying |       |  0.65 |      |       |       1.36 |       0.50
> LIE_20   |                    I do not have to prepare much for a lie |       |  0.58 |      |       |       1.58 |       0.58
> LIE_19   |                I find it taxing to come up with a good lie |       | -0.49 |      |       |       1.90 |       0.62
> LIE_27   |                        I feel tense whenever I have to lie |       | -0.49 |      |       |       2.00 |       0.56
> LIE_16   |                 My lies often arouse suspicion from others |       | -0.46 |      |       |       2.01 |       0.68
> LIE_41   |                             Lying is against my principles |       |       | 0.62 |       |       1.69 |       0.49
> LIE_34   |                              I always avoid lying if I can |       |       | 0.57 |       |       1.85 |       0.51
> LIE_44   |                                          It is bad to lie  |       |       | 0.55 |       |       1.62 |       0.61
> LIE_25   |                                  I feel guilty after lying |       |       | 0.54 |       |       1.69 |       0.60
> LIE_36   | I prefer to tell the truth even if it gets me into trouble |       |       | 0.46 |       |       1.69 |       0.71
> LIE_35   |                 I would only lie if I have no other choice |       |       | 0.36 |       |       2.22 |       0.75
> LIE_37   |                      I would never lie for trivial matters |       |       | 0.34 |       |       1.42 |       0.86
> LIE_38   |                      I would never lie in serious contexts |       |       | 0.31 |       |       1.46 |       0.88
> LIE_43   |                               It is okay to lie sometimes  |       |       |      |  0.71 |       1.30 |       0.42
> LIE_33   |                                       I lie when necessary |       |       |      |  0.69 |       1.17 |       0.48
> LIE_42   |           It is acceptable to lie depending on the context |       |       |      |  0.62 |       1.38 |       0.54
> LIE_39   |            I would lie if something important was at stake |       |       |      |  0.47 |       1.30 |       0.74
> LIE_40   |                         I would only lie if it is harmless |       |       |      |  0.46 |       1.20 |       0.77
> LIE_30   |              I lie when it’s easier than telling the truth |       |       |      |  0.38 |       2.07 |       0.75
> LIE_32   |            I lie when telling the truth is too troublesome |       |       |      |  0.38 |       2.29 |       0.73
> LIE_3    |                                          I never tell lies |       |       |      | -0.32 |       2.33 |       0.81
> 
> The 4 latent factors (varimax rotation) accounted for 43.00% of the total variance of the original data (ML2 = 14.42%, ML1 = 14.41%, ML4 = 7.18%, ML3 = 6.98%).

One latent factors model

efa_1 <- psych::fa(cor, n.obs = nrow(lie_EFA), nfactors = 1, rotate = "varimax", fm = "ml") 

parameters::model_parameters(efa_1, labels = labels_lie$Description) %>% 
  print(sort = TRUE, threshold = "max") 
> # Rotated loadings from Factor Analysis (varimax-rotation)
> 
> Variable |                                                      Label |   ML1 | Complexity | Uniqueness
> -------------------------------------------------------------------------------------------------------
> LIE_10   |                                             I can lie well |  0.83 |       1.00 |       0.31
> LIE_9    |                                           I am a good liar |  0.81 |       1.00 |       0.34
> LIE_11   |                              I am good at deceiving others |  0.77 |       1.00 |       0.41
> LIE_18   |                   It is easy for me to make up clever lies |  0.75 |       1.00 |       0.44
> LIE_17   |                                     I find lying difficult | -0.71 |       1.00 |       0.50
> LIE_14   |                    It is hard for others to detect my lies |  0.67 |       1.00 |       0.55
> LIE_12   |                         I can lie effectively if I want to |  0.64 |       1.00 |       0.59
> LIE_20   |                    I do not have to prepare much for a lie |  0.63 |       1.00 |       0.60
> LIE_1    |                                           I lie frequently |  0.62 |       1.00 |       0.61
> LIE_15   |                            I almost never get caught lying |  0.62 |       1.00 |       0.62
> LIE_2    |                                   I lie in many situations |  0.58 |       1.00 |       0.66
> LIE_4    |                                   I have a tendency to lie |  0.57 |       1.00 |       0.67
> LIE_5    |                      I lie more often than most people do  |  0.57 |       1.00 |       0.68
> LIE_26   |                                              I enjoy lying |  0.55 |       1.00 |       0.70
> LIE_13   |                      Others can easily tell when I’m lying | -0.53 |       1.00 |       0.72
> LIE_41   |                             Lying is against my principles | -0.53 |       1.00 |       0.72
> LIE_27   |                        I feel tense whenever I have to lie | -0.51 |       1.00 |       0.73
> LIE_29   |                             I lie whenever it’s convenient |  0.51 |       1.00 |       0.74
> LIE_19   |                I find it taxing to come up with a good lie | -0.50 |       1.00 |       0.75
> LIE_23   |           I find it difficult to refrain myself from lying |  0.49 |       1.00 |       0.76
> LIE_28   |                I feel satisfied when others believe my lie |  0.49 |       1.00 |       0.76
> LIE_25   |                                  I feel guilty after lying | -0.47 |       1.00 |       0.78
> LIE_6    |         I lie more frequently than what I expect myself to |  0.46 |       1.00 |       0.79
> LIE_44   |                                          It is bad to lie  | -0.45 |       1.00 |       0.80
> LIE_31   |       I lie if it’s the most direct way to get what I want |  0.44 |       1.00 |       0.81
> LIE_22   |                     I find myself lying without any reason |  0.44 |       1.00 |       0.81
> LIE_43   |                               It is okay to lie sometimes  |  0.42 |       1.00 |       0.83
> LIE_34   |                              I always avoid lying if I can | -0.42 |       1.00 |       0.83
> LIE_8    |                            Others lie less often than I do |  0.41 |       1.00 |       0.83
> LIE_7    |                           I lie more than I think I should |  0.40 |       1.00 |       0.84
> LIE_42   |           It is acceptable to lie depending on the context |  0.40 |       1.00 |       0.84
> LIE_36   | I prefer to tell the truth even if it gets me into trouble | -0.39 |       1.00 |       0.85
> LIE_33   |                                       I lie when necessary |  0.37 |       1.00 |       0.86
> LIE_32   |            I lie when telling the truth is too troublesome |  0.33 |       1.00 |       0.89
> LIE_30   |              I lie when it’s easier than telling the truth |  0.33 |       1.00 |       0.89
> LIE_16   |                 My lies often arouse suspicion from others | -0.26 |       1.00 |       0.93
> LIE_3    |                                          I never tell lies | -0.26 |       1.00 |       0.93
> LIE_39   |            I would lie if something important was at stake |  0.25 |       1.00 |       0.94
> LIE_38   |                      I would never lie in serious contexts | -0.24 |       1.00 |       0.94
> LIE_37   |                      I would never lie for trivial matters | -0.21 |       1.00 |       0.96
> LIE_21   |                          I have to try hard to avoid lying |  0.14 |       1.00 |       0.98
> LIE_40   |                         I would only lie if it is harmless |  0.14 |       1.00 |       0.98
> LIE_24   |                  It is easy to hold back from telling lies | -0.11 |       1.00 |       0.99
> LIE_35   |                 I would only lie if I have no other choice | -0.08 |       1.00 |       0.99
> 
> The unique latent factor (varimax rotation) accounted for 24.63% of the total variance of the original data.
paste0("The model with one, and four factors accounted for ",
       report::format_text(c(insight::format_value(efa_1$Vaccounted[2,]*100),
                             insight::format_value(efa_4$Vaccounted[3, 4]*100))),
       "% of variance of the dataset.")
> [1] "The model with one, and four factors accounted for 24.63 and 43.00% of variance of the dataset."

The factor number exploration suggested the presence of four and one latent factor(s). We therefore decided to keep the unique and four-factors models and submitted their simple structure to Confirmatory Factor Analysis (CFA)

Confirmatory Factor Analysis (CFA)

Model Selection

report_cfa_indices <- function(comparison, row=1, name="<model>"){
  paste0("(X2", name, " = ", insight::format_value(comparison[row, "Chisq"]),
        ", AIC", name, " = ", insight::format_value(comparison[row, "AIC"]),
        ", BIC", name, " = ", insight::format_value(comparison[row, "BIC_adjusted"]),
        ", RMSEA", name, " = ", insight::format_value(comparison[row, "RMSEA"]),
        ", CFI", name, " = ", insight::format_value(comparison[row, "CFI"]),
        ", SRMR", name, " = ", insight::format_value(comparison[row, "SRMR"]),
        ")")
}
One vs. Four Factors
cfa_4 <- parameters::efa_to_cfa(efa_4, threshold = "max") %>% 
  lavaan::cfa(data = lie_CFA)
cfa_1 <- parameters::efa_to_cfa(efa_1, threshold = "max") %>% 
  lavaan::cfa(data = lie_CFA)
comparison_4vs1 <- performance::compare_performance(cfa_4, cfa_1) %>% 
  select(Model, AIC, BIC, BIC_adjusted, Chi2, RMSEA, CFI, SRMR)

display(comparison_4vs1)
Comparison of Model Performance Indices
Model AIC BIC BIC_adjusted Chi2 RMSEA CFI SRMR
cfa_4 57650.70 58000.41 57702.29 2142.55 0.07 0.82 0.09
cfa_1 59691.09 60018.48 59739.39 4194.94 0.11 0.53 0.12

The confirmatory factor analysis favoured the four-factors solution over the one-factor solution.

Four-factors vs. Initial Model
# Initial Model
model_initial <- c()
for (dimension in unique(labels_lie$Dimension)) {
  model_initial <- c(
    model_initial,
    paste0(tools::toTitleCase(dimension), " =~ ", paste(as.character(labels_lie[labels_lie$Dimension == dimension, "Item"]), collapse = " + "))
  )
}
cfa_initial <- paste0(model_initial, collapse = "\n") %>% 
  lavaan::cfa(data = lie_CFA)
comparison_4vsinitial <- performance::compare_performance(cfa_4, cfa_initial) %>% 
  select(Model, AIC, BIC, BIC_adjusted, Chi2, RMSEA, CFI, SRMR)
display(comparison_4vsinitial)
Comparison of Model Performance Indices
Model AIC BIC BIC_adjusted Chi2 RMSEA CFI SRMR
cfa_4 57650.70 58000.41 57702.29 2142.55 0.07 0.82 0.09
cfa_initial 58197.46 58536.01 58247.40 2695.31 0.08 0.74 0.10

We then compared the four-factors solution with the initial hypothetic model with which we built the scale, which favoured the four-factors model

Short vs. Long Form
cfa_4_short3 <- parameters::efa_to_cfa(efa_4, threshold = 3, names = c( "Frequency", "Ability", "Negativity", "Contextuality")) %>% 
  lavaan::cfa(data = lie_CFA)
cfa_4_short4 <- parameters::efa_to_cfa(efa_4, threshold = 4, names = c( "Frequency", "Ability", "Negativity", "Contextuality")) %>% 
  lavaan::cfa(data = lie_CFA)
cfa_4_short5 <- parameters::efa_to_cfa(efa_4, threshold = 5, names = c( "Frequency", "Ability", "Negativity", "Contextuality")) %>% 
  lavaan::cfa(data = lie_CFA)
comparison_4vs4short <- performance::compare_performance(cfa_4, cfa_4_short3, cfa_4_short4, cfa_4_short5) %>% 
  select(Model, AIC, BIC, BIC_adjusted, Chi2, RMSEA, CFI, SRMR)
display(comparison_4vs4short)
Comparison of Model Performance Indices
Model AIC BIC BIC_adjusted Chi2 RMSEA CFI SRMR
cfa_4 57650.70 58000.41 57702.29 2142.55 0.07 0.82 0.09
cfa_4_short3 15296.48 15408.09 15312.94 117.05 0.07 0.96 0.06
cfa_4_short4 20309.91 20451.28 20330.76 223.80 0.06 0.95 0.06
cfa_4_short5 25408.64 25579.78 25433.89 322.18 0.06 0.95 0.06
cfa_4 15296.48 15408.09
cfa_4_short3 20309.91 20451.28
cfa_4_short4 25408.64 25579.78
cfa_4_short5 57650.70 58000.41

Finally, we compared the full four-factors model (including all items) with short form retaining only the 3, 4 or 5 most loading items for each of the 4 dimensions. The 3-items version outperformed all versions, including 5-items and 4-items. Nonetheless, as 3-items per construct is the bare minimum for adequate reliability, we decided to keep the second best performing version with 4-items per factor, which also displayed excellent indices of fit.

table_comparison <- distinct(bind_rows(
  as.data.frame(comparison_4vs1),
  as.data.frame(comparison_4vsinitial),
  as.data.frame(comparison_4vs4short)
)) %>% 
  mutate(Model = case_when(
  Model == "cfa_4" ~ "Four Factors: all items",
  Model == "cfa_1" ~ "One Factor: all items",
  Model == "cfa_initial" ~ "Hypothesized: all items",
  Model == "cfa_4_short3" ~ "Four Factors: 3 items",
  Model == "cfa_4_short4" ~ "Four Factors: 4 items",
  Model == "cfa_4_short5" ~ "Four Factors: 5 items"
  ))


write.csv(table_comparison, "figures/table_comparison.csv", row.names = FALSE)

Model Description

# Refit the cfa model with the full sample
cfa_4_short4_full <- parameters::efa_to_cfa(efa_4, threshold = 4, names = c( "Frequency", "Ability", "Negativity", "Contextuality")) %>% 
  lavaan::cfa(data = lie)

cfa_parameters <- model_parameters(cfa_4_short4_full, standardize = FALSE)
cfa_parameters
To Operator From Coefficient SE CI_low CI_high p Type
1 Frequency =~ LIE_1 1.00 0.00 1.00 1.00 0 Loading
2 Frequency =~ LIE_4 1.01 0.04 0.93 1.09 0 Loading
3 Frequency =~ LIE_5 0.92 0.04 0.85 1.00 0 Loading
4 Frequency =~ LIE_23 0.82 0.04 0.74 0.90 0 Loading
5 Ability =~ LIE_9 1.00 0.00 1.00 1.00 0 Loading
6 Ability =~ LIE_10 1.05 0.03 0.99 1.10 0 Loading
7 Ability =~ LIE_14 0.77 0.03 0.71 0.83 0 Loading
8 Ability =~ LIE_18 0.87 0.03 0.81 0.94 0 Loading
9 Negativity =~ LIE_25 1.00 0.00 1.00 1.00 0 Loading
10 Negativity =~ LIE_34 0.86 0.06 0.73 0.99 0 Loading
11 Negativity =~ LIE_41 1.30 0.09 1.12 1.48 0 Loading
12 Negativity =~ LIE_44 1.07 0.08 0.91 1.22 0 Loading
13 Contextuality =~ LIE_33 1.00 0.00 1.00 1.00 0 Loading
14 Contextuality =~ LIE_39 0.78 0.07 0.64 0.92 0 Loading
15 Contextuality =~ LIE_42 1.03 0.07 0.90 1.16 0 Loading
16 Contextuality =~ LIE_43 1.21 0.07 1.06 1.35 0 Loading
37 Frequency ~~ Ability 2.30 0.22 1.87 2.74 0 Correlation
38 Frequency ~~ Negativity -1.78 0.18 -2.13 -1.44 0 Correlation
39 Frequency ~~ Contextuality 0.79 0.14 0.52 1.06 0 Correlation
40 Ability ~~ Negativity -1.74 0.19 -2.12 -1.37 0 Correlation
41 Ability ~~ Contextuality 1.59 0.18 1.24 1.94 0 Correlation
42 Negativity ~~ Contextuality -0.88 0.12 -1.12 -0.64 0 Correlation
data <- see::data_plot(cfa_parameters, ci=FALSE)

data$nodes <- mutate(data$nodes, Name = stringr::str_replace(Name, "LIE_", "Q")) 
data$edges <- mutate(data$edges, from = stringr::str_replace(from, "LIE_", "Q"))

p <- tidygraph::tbl_graph(data$nodes, data$edges) %>%
  ggraph::ggraph(layout = 'fr') +
  ggraph::geom_edge_arc(aes(alpha = as.numeric(Type == "Correlation"),
                    label = Label_Correlation,
                    color = Coefficient),
                    strength = 0.1,
                    edge_width = 1.5,
                    label_dodge = unit(2, "mm"),
                    linetype = 1, angle_calc = "along",
                    label_size = 3,
                    start_cap = ggraph::circle(0, 'mm'), end_cap = ggraph::circle(0, 'mm')) +
  ggraph::geom_edge_link(aes(alpha = as.numeric(Type == "Loading"),
                     label = Label_Loading,
                     color = Coefficient),
                     label_dodge = unit(2, "mm"),
                     angle_calc = "along", 
                     edge_width = 0.9,
                     label_size = 3,
                     check_overlap = TRUE,
                     arrow = arrow(type = "closed", length = unit(3, "mm")),
                     start_cap = ggraph::circle(0, 'mm'), end_cap = ggraph::circle(-12, 'mm')) +
  ggraph::geom_node_point(aes(colour = Name, size = Latent)) +
  ggraph::geom_node_text(aes(label = Name))  +
  ggraph::scale_edge_colour_gradient2(
    guide = FALSE,
    high = "#4CAF50",
    mid = "#FFF9C4",
    low = "#E91E63"
  ) +
  scale_alpha(guide = FALSE, range = c(0, 1)) +
  scale_size_manual(values=c("TRUE"=33, "FALSE"=22)) +
  scale_color_manual(values=c("Negativity"="#E91E63", "Q41"="#EC407A", "Q44"="#F06292", "Q34"="#F48FB1", "Q25"="#F8BBD0",
                              "Contextuality"="#FF9800", "Q43"="#FFA726", "Q42"="#FFB74D", "Q33"="#FFCC80", "Q39"="#FFE0B2",
                              "Frequency"="#4CAF50", "Q1"="#66BB6A", "Q4"="#81C784", "Q5"="#A5D6A7", "Q23"="#C8E6C9",
                              "Ability"="#2196F3", "Q10"="#42A5F5", "Q9"="#64B5F6", "Q18"="#90CAF9", "Q14"="#BBDEFB")) +
  ggraph::scale_edge_alpha(guide = FALSE, range = c(0, 1)) +
  scale_x_continuous(expand = expand_scale(c(0.07, 0.07))) +
  scale_y_continuous(expand = expand_scale(c(0.07, 0.07))) +
  ggraph::theme_graph() +
  theme(legend.position = "none")

ggsave("figures/figure_CFA.png", p, height=figwidth*0.8, width=figwidth*0.8)

Loadings Table

table_efa <- as.data.frame(sort(parameters::model_parameters(efa_4, labels = labels_lie$Description)))[,1:6] %>% 
  mutate(Variable = as.character(Variable)) %>% 
  mutate_if(is.numeric, insight::format_value)
names(table_efa) <- c("Item", "Label", "Frequency", "Ability", "Negativity", "Contextuality")

table_cfa <- as.data.frame(parameters::model_parameters(cfa_4_short4_full)) %>% 
  filter(Type == "Loading") %>% 
  select(To, Item=From, Coefficient) %>% 
  pivot_wider(names_from=To, values_from=Coefficient, names_prefix="CFA_") %>% 
  mutate(Item = as.character(Item)) 

table <- full_join(table_efa, table_cfa, by="Item") %>% 
  mutate_if(is.numeric, insight::format_value) %>% 
  mutate(Frequency = paste0(Frequency, " [", CFA_Frequency, "]"),
         Ability = paste0(Ability, " [", CFA_Ability, "]"),
         Negativity = paste0(Negativity, " [", CFA_Negativity, "]"),
         Contextuality = paste0(Contextuality, " [", CFA_Contextuality, "]"),
         Item = stringr::str_replace(Item, "LIE_", "Q")) %>% 
  mutate_all(function(x) stringr::str_remove_all(x, " \\[]")) %>% 
  select(Item, Label, Frequency, Ability, Negativity, Contextuality)
write.csv(table, "figures/table_loadings.csv", row.names = FALSE)

Compute Scores

lie <- predict(cfa_parameters)
names(lie) <- paste0("LIE_", names(lie))
lie %>% 
  select(starts_with("LIE_")) %>% 
  report() %>% 
  as.data.frame() %>% 
  select(-one_of(c("n_Obs", "Median", "MAD", "n_Missing"))) %>% 
  print()
> Variable          |      Mean |   SD |   Min |  Max | Skewness | Kurtosis | percentage_Missing
> ----------------------------------------------------------------------------------------------
> LIE_Frequency     |  1.80e-17 | 1.86 | -3.24 | 5.34 |     0.26 |    -0.65 |               0.00
> LIE_Ability       | -5.60e-17 | 2.33 | -5.12 | 4.71 |    -0.32 |    -0.74 |               0.00
> LIE_Negativity    | -1.48e-18 | 1.32 | -4.44 | 2.87 |    -0.08 |    -0.31 |               0.00
> LIE_Contextuality |  1.62e-17 | 1.34 | -5.17 | 2.60 |    -0.89 |     1.38 |               0.00
p_distrib <- lie %>% 
  select(starts_with("LIE_")) %>% 
  dplyr::rename_all(.funs = list(~ sub("LIE_*", "", .))) %>%
  bayestestR::estimate_density(method = "KernSmooth") %>% 
  see::data_plot() %>% 
  mutate(Parameter = fct_relevel(Parameter, "Frequency", "Ability", "Negativity", "Contextuality")) %>% 
  ggplot(aes(x=x, y=y, color=Parameter)) +
  geom_line(size=2) +
  # ggtitle("Distribution of the LIE dimensions") +
  xlab("Score\n") +
  ylab("Distribution") +
  theme_modern() +
  scale_color_manual(values=c("Frequency"= "#2196F3", "Ability"="#4CAF50", "Negativity"="#E91E63", "Contextuality"="#FF9800"), name = "Dimensions")

Reliability

Cronbach’s alpha

paste0("All subscales of the LIE scale, namely, Frequency (alpha = ",
       insight::format_value(performance::cronbachs_alpha(select(df, LIE_1, LIE_4, LIE_5, LIE_23))),
       "), Ability (alpha = ",
        insight::format_value(performance::cronbachs_alpha(select(df, LIE_9, LIE_10, LIE_14, LIE_18))),
       "), Contextuality (alpha = ",
        insight::format_value(performance::cronbachs_alpha(select(df, LIE_33, LIE_39, LIE_42, LIE_43))),
       ") and Negativity (alpha = ", 
        insight::format_value(performance::cronbachs_alpha(select(df, LIE_25, LIE_34, LIE_41, LIE_44))),
       ") have a high reliability.")
> [1] "All subscales of the LIE scale, namely, Frequency (alpha = 0.86), Ability (alpha = 0.90), Contextuality (alpha = 0.75) and Negativity (alpha = 0.75) have a high reliability."
# library(formattable)

questions <- dplyr::select(df, dplyr::one_of(row.names(lavaan::lavInspect(cfa_4_short4_full)$lambda)))


om <- psych::omega(m = questions, nfactors = 4, fm = "ml", title = "Omega of LIE Scale", plot = "FALSE", n.obs = nrow(questions), flip=FALSE) # ωh = 0.36, ωt = 0.83 

# Table of omega coefficients
table_om <- om$omega.group
rownames(table_om) <- c("All items","Frequency", "Ability", "Negativity", "Contextuality")
colnames(table_om) <- c("Omega (total)", "Omega (hierarchical)", "Omega (group)")
table_om
Omega (total) Omega (hierarchical) Omega (group)
All items 0.83 0.36 0.50
Frequency 0.91 0.44 0.47
Ability 0.87 0.37 0.50
Negativity 0.76 0.19 0.57
Contextuality 0.75 0.37 0.38
# Table of variance accounted for
table_variance <- om$omega.group %>%
  mutate(Composite = c("All items", "Frequency", "Ability", "Negativity", "Contextuality")) %>%
  mutate(Total = total*100,
         General = general*100,
         Group = group*100) %>%
  select(Composite, Total, General, Group)
colnames(table_variance) <- c("Composite", "Total Variance (%)", "Variance due to General Factor (%)", "Variance due to Group Factor (%)")
table_variance 
Composite Total Variance (%) Variance due to General Factor (%) Variance due to Group Factor (%)
All items 83 36 50
Frequency 91 44 47
Ability 87 37 50
Negativity 76 19 57
Contextuality 75 37 38
psych::cor.plot(om)

Cluster Structure

Cluster Tendency

parameters::check_clusterstructure(lie, standardize = FALSE) %T>%
  print() %>%
  plot()
> # Clustering tendency
> 
> The dataset is suitable for clustering (Hopkins' H = 0.24).

How many clusters

parameters::n_clusters(lie, standardize = FALSE) %T>%
  print() %>% 
  plot() +
  theme_modern()
> # Method Agreement Procedure:
> 
> The choice of 3 clusters is supported by 11 (39.29%) methods out of 28 (KL, Hartigan, Scott, Marriot, TrCovW, TraceW, Friedman, Rubin, Ball, PtBiserial, Mixture).

The agreement procedure, combining 28 different methods for determining the optimal number of clusters, supported the existence of 2 (8/28) or 3 (11/28) clusters.

Clustering

K-means

set.seed(333)

k2 <- kmeans(lie, centers=2, iter.max = 10000, nstart = 1000)
k3 <- kmeans(lie, centers=3, iter.max = 10000, nstart = 1000)

model_parameters(k2) 
Cluster n_Obs Sum_Squares LIE_Frequency LIE_Ability LIE_Negativity LIE_Contextuality
1 310 2256 -1.42 -2.1 0.97 -0.74
2 452 2947 0.97 1.5 -0.67 0.50
model_parameters(k3) 
Cluster n_Obs Sum_Squares LIE_Frequency LIE_Ability LIE_Negativity LIE_Contextuality
1 319 1711 -0.53 0.19 0.15 0.11
2 267 1317 1.85 1.92 -1.09 0.61
3 176 979 -1.85 -3.25 1.38 -1.13
paste0("We applied k-means clustering, which revealed that grouping the participants in 2 and 3 clusters would account for ",
       insight::format_value(attributes(model_parameters(k2))$variance*100),
       "% and ",
       insight::format_value(attributes(model_parameters(k3))$variance*100),
       "% of the total variance of the four dimensions of the questionnaire, respectively.",
       " Thus, we decided to go ahead with the latter solution.")
> [1] "We applied k-means clustering, which revealed that grouping the participants in 2 and 3 clusters would account for 44.92% and 57.58% of the total variance of the four dimensions of the questionnaire, respectively. Thus, we decided to go ahead with the latter solution."

Compute Profiles

lie$LIE_Profile <- model_parameters(k3) %>% 
  predict(names = c("Average", "Trickster", "Virtuous")) 

paste0('We then assigned each participant to its nearest cluster, labelling them as Average (',
       insight::format_value(sum(lie$LIE_Profile=="Average")/nrow(lie)*100),
       "% of the sample; people that report an average lying ability, slightly lower than average frequency, average negativity and contextuality), Trickster (",
       insight::format_value(sum(lie$LIE_Profile=="Trickster")/nrow(lie)*100),
       "%; people with high reported lying ability, frequency, low negative experience associated with deception and above-average flexibility in its implementation), and Virtuous (",
       insight::format_value(sum(lie$LIE_Profile=="Virtuous")/nrow(lie)*100),
       "%; people with very low reported lying ability and frequency, strong negative emotions and moral attitude associated with lying and high rigidity in their (non-)usage of deception).")
> [1] "We then assigned each participant to its nearest cluster, labelling them as Average (41.86% of the sample; people that report an average lying ability, slightly lower than average frequency, average negativity and contextuality), Trickster (35.04%; people with high reported lying ability, frequency, low negative experience associated with deception and above-average flexibility in its implementation), and Virtuous (23.10%; people with very low reported lying ability and frequency, strong negative emotions and moral attitude associated with lying and high rigidity in their (non-)usage of deception)."

Visualisation

colors_cluster <- c("Average" = "#D500F9", "Trickster" = "#F50057", "Virtuous" = "#3D5AFE")

p_profiles <- lie %>% 
  select(starts_with("LIE_")) %>% 
  pivot_longer(-LIE_Profile, names_to = "Dimension", values_to = "Score") %>%
  mutate(LIE_Profile = fct_relevel(LIE_Profile, "Trickster", "Average", "Virtuous"),
         Dimension = str_remove(Dimension, "LIE_"),
         Dimension = fct_relevel(Dimension, "Frequency", "Ability", "Negativity", "Contextuality")) %>% 
  group_by(LIE_Profile, Dimension) %>% 
  summarise_all(mean) %>%
  rename(Profile = LIE_Profile) %>% 
  ggplot(aes(x = Dimension, y = Score, color = Profile, group = Profile)) +
  geom_line(key_glyph = "label") +
  geom_polygon(fill = NA, size = 2.5, show.legend = FALSE) +
  scale_color_manual(values = colors_cluster) +
  theme_minimal() +
  xlab("") + ylab("") +
  scale_y_continuous(breaks = c(-2, 0, 2), expand = expand_scale(c(.10, 0))) +
  # scale_y_continuous(limits = c(-5, 5)) +
  theme(axis.ticks.y = element_blank(),
        axis.text.y = element_blank(),
        legend.title = element_text(face="bold", size=15),
        panel.grid.major.y = element_line(color="#E0E0E0", linetype="longdash"),
        panel.grid.major.x = element_blank(),
        legend.text = element_text(size=13),
        axis.text.x = element_text(
          vjust = -0.5,
          size = 13,
          # face="bold",
          color="black")) +
  coord_radar(start = -pi/4, clip="off")
# Combine plots
p <- cowplot::plot_grid(p_distrib, p_profiles, nrow=2, labels = c('A', 'B'), label_size = 14)
ggsave("figures/figure_dimensions.png", p, height=figheight, width=figwidth*0.9)

Convergent Validity

df <- cbind(df, lie) %>%
  select(-matches("LIE_\\d"))

Demographics

Sex

library(rstanarm)

model_dimensional <- stan_glm(Sex ~ LIE_Ability + LIE_Frequency + LIE_Contextuality + LIE_Negativity, data=df, family = "binomial", refresh = 0, seed=333)
model_profile <- stan_glm(Sex ~ LIE_Profile, data = df, family = "binomial", refresh = 0, seed=333)

performance::compare_performance(model_dimensional, model_profile, metrics = c("LOOIC", "R2"))
Model Type ELPD ELPD_SE LOOIC LOOIC_SE R2
model_dimensional stanreg -516 5.8 1032 12 0.03
model_profile stanreg -516 5.5 1031 11 0.03
parameters::parameters_table(model_parameters(model_profile))
Parameter Median 89% CI pd % in ROPE Rhat ESS Prior
(Intercept) -0.28 [-0.48, -0.11] 99.55% 18.27% 1.000 3263.44 Normal (0 +- 2.50)
LIE_ProfileTrickster 0.41 [ 0.13, 0.67] 99.15% 8.65% 1.000 3160.38 Normal (0 +- 5.24)
LIE_ProfileVirtuous -0.48 [-0.81, -0.19] 99.38% 5.97% 0.999 3175.49 Normal (0 +- 5.93)
parameters::parameters_table(model_parameters(model_dimensional))
Parameter Median 89% CI pd % in ROPE Rhat ESS Prior
1 (Intercept) -0.25 [-0.37, -0.13] 99.95% 17.12% 1.000 4012.38 Normal (0 +- 2.50)
2 LIE_Ability 0.14 [ 0.07, 0.21] 99.85% 85.78% 1.001 3114.18 Normal (0 +- 1.08)
4 LIE_Frequency 0.02 [-0.07, 0.11] 63.68% 99.70% 1.001 2445.17 Normal (0 +- 1.34)
3 LIE_Contextuality -0.04 [-0.14, 0.07] 70.62% 98.00% 1.000 3305.41 Normal (0 +- 1.87)
5 LIE_Negativity -0.06 [-0.19, 0.08] 74.08% 92.38% 1.002 2090.23 Normal (0 +- 1.89)
model_profile %>%
  estimate_means() %>%
  mutate(LIE_Profile = fct_relevel(LIE_Profile, "Trickster", "Average", "Virtuous")) %>%
  ggplot(aes(x = LIE_Profile, y = Probability, color = LIE_Profile)) +
  geom_line(aes(group = 1), size = 1) +
  geom_pointrange(aes(ymin = CI_low, ymax = CI_high), size = 1) +
  theme_modern() +
  scale_color_manual(values = colors_cluster, guide = FALSE) +
  ylab("Probability of being a Male") +
  xlab("Deception Profile")

df %>%
  select(Participant, Sex, starts_with("LIE_"), -LIE_Profile) %>%
  pivot_longer(-c(Sex, Participant), names_to = "Dimension", values_to = "Score") %>%
  mutate(Dimension = str_remove(Dimension, "LIE_"),
         Dimension = fct_relevel(Dimension, "Frequency", "Ability", "Negativity", "Contextuality")) %>%
  ggplot(aes(x = Dimension, y = Score)) +
  geom_boxplot(aes(fill = Sex, color = Sex)) +
  scale_fill_manual(values = c("Male" = "#2196F3", "Female" = "#F06292")) +
  scale_color_manual(values = c("Male" = "#2196F3", "Female" = "#F06292")) +
  theme_modern() +
  coord_flip()

sig <- model_parameters(model_dimensional)[-1,] %>%
  select(Parameter, pd) %>%
  mutate(Dimension = stringr::str_remove(Parameter, "LIE_"),
         Text = insight::format_pd(pd, stars_only=TRUE),
         Predicted = 0.6,
         Score = df %>%
           select(one_of(Parameter)) %>%
           summarise_all(function(x) {mean(range(x))}) %>%
           t()) %>%
  mutate(Dimension = fct_relevel(Dimension, "Frequency", "Ability", "Negativity", "Contextuality"))

p_sex <- rbind(estimate_link(model_dimensional, target="LIE_Ability") %>%
        mutate(LIE_Frequency = NA, LIE_Contextuality=NA, LIE_Negativity=NA),
      estimate_link(model_dimensional, target="LIE_Frequency") %>%
        mutate(LIE_Ability = NA, LIE_Contextuality=NA, LIE_Negativity=NA),
      estimate_link(model_dimensional, target="LIE_Contextuality") %>%
        mutate(LIE_Frequency = NA, LIE_Ability=NA, LIE_Negativity=NA),
      estimate_link(model_dimensional, target="LIE_Negativity") %>%
        mutate(LIE_Frequency = NA, LIE_Contextuality=NA, LIE_Ability=NA)) %>%
  pivot_longer(cols=starts_with("LIE_"), names_to="Dimension", values_to = "Score") %>%
  mutate(Dimension = str_remove(Dimension, "LIE_"),
         Dimension = fct_relevel(Dimension, "Frequency", "Ability", "Negativity", "Contextuality")) %>%
  ggplot(aes(x = Score, y = Predicted)) +
  geom_ribbon(aes(ymin=CI_low, ymax=CI_high, fill=Dimension), alpha=0.1) +
  geom_line(aes(color=Dimension), size = 1) +
  geom_text(data = sig, aes(label = Text)) +
  theme_modern() +
  theme(strip.placement = "outside",
        strip.text = element_text(size=13, face="plain"),
        axis.title = element_text(size=13),
        axis.text = element_text(size=9),
        plot.title = element_text(face="bold", hjust = 0.5)) +
  ggtitle("Sex") +
  ylab("Probability of being a Male") +
  xlab("") +
  scale_color_manual(values=c("Ability"= "#2196F3", "Frequency"="#4CAF50", "Negativity"="#E91E63", "Contextuality"="#FF9800"), name = "Dimensions", guide=FALSE) +
   scale_fill_manual(values=c("Ability"= "#2196F3", "Frequency"="#4CAF50", "Negativity"="#E91E63", "Contextuality"="#FF9800"), name = "Dimensions", guide=FALSE) +
  facet_wrap(~Dimension, scales="free_x", strip.position = "bottom")

Age

model_dimensional <- stan_lmer(Age ~ LIE_Ability + LIE_Frequency + LIE_Contextuality + LIE_Negativity + Income + Education + (1|Sex), data = df, refresh = 0, seed=333)
model_profile <- stan_lmer(Age ~ LIE_Profile + Income + Education + (1|Sex), data = df, refresh = 0, seed=333)

performance::compare_performance(model_dimensional, model_profile)
Model Type ELPD ELPD_SE LOOIC LOOIC_SE WAIC R2 R2_marginal R2_adjusted RMSE Sigma
model_dimensional stanreg -2194 37 4389 74 4389 0.26 0.26 0.23 6.7 6.7
model_profile stanreg -2190 37 4381 74 4381 0.27 0.27 0.24 6.6 6.7
parameters::parameters_table(model_parameters(model_profile))
Parameter Median 89% CI pd % in ROPE Rhat ESS Prior
1 (Intercept) 31.45 [29.35, 33.53] 100% 0% 1.003 677.60 Normal (25.49 +- 19.39)
4 LIE_ProfileTrickster -0.43 [-1.37, 0.55] 76.42% 70.10% 1.000 2547.36 Normal (0.00 +- 40.55)
5 LIE_ProfileVirtuous 2.81 [ 1.68, 4.01] 100% 0.15% 1.012 432.57 Normal (0.00 +- 46.51)
3 Income 1.81e-04 [ 0.00, 0.00] 99.80% 100% 1.001 3554.29 Normal (0.00 +- 4.45e-03)
2 Education -1.97 [-2.18, -1.76] 100% 0% 1.001 2231.96 Normal (0.00 +- 9.71)
parameters::parameters_table(model_parameters(model_dimensional))
Parameter Median 89% CI pd % in ROPE Rhat ESS Prior
1 (Intercept) 31.75 [26.74, 33.56] 100% 0% 1.009 45.23 Normal (25.49 +- 19.39)
4 LIE_Ability -0.36 [-0.60, -0.13] 99.17% 99.83% 1.001 916.81 Normal (0.00 +- 8.39)
6 LIE_Frequency 6.87e-03 [-0.25, 0.41] 51.68% 100% 1.002 341.15 Normal (0.00 +- 10.26)
5 LIE_Contextuality -0.26 [-0.62, 0.13] 86.00% 98.88% 1.007 1194.04 Normal (0.00 +- 14.46)
7 LIE_Negativity 0.19 [-0.29, 0.70] 74.62% 97.10% 1.002 477.24 Normal (0.00 +- 14.51)
3 Income 1.80e-04 [ 0.00, 0.00] 99.75% 100% 1.015 306.85 Normal (0.00 +- 4.45e-03)
2 Education -1.92 [-2.13, -1.70] 100% 0% 1.007 531.72 Normal (0.00 +- 9.71)
model_profile %>%
  estimate_means() %>%
  mutate(LIE_Profile = fct_relevel(LIE_Profile, "Trickster", "Average", "Virtuous")) %>%
  ggplot(aes(x = LIE_Profile, y = Mean, color = LIE_Profile)) +
  geom_line(aes(group = 1), size = 1) +
  geom_pointrange(aes(ymin = CI_low, ymax = CI_high), size = 1) +
  theme_modern() +
  scale_color_manual(values = colors_cluster, guide = FALSE) +
  ylab("Age") +
  xlab("Deception Profile")

sig <- model_parameters(model_dimensional)[2:5,] %>%
  select(Parameter, pd) %>%
  mutate(Dimension = stringr::str_remove(Parameter, "LIE_"),
         Text = format_pd(pd, stars_only=TRUE),
         Predicted = 29,
         Score = df %>%
           select(one_of(Parameter)) %>%
           summarise_all(function(x) {mean(range(x))}) %>%
           t()) %>%
  mutate(Dimension = fct_relevel(Dimension, "Frequency", "Ability", "Negativity", "Contextuality"))

p_age <- rbind(estimate_link(model_dimensional, target="LIE_Frequency") %>%
        mutate(LIE_Ability = NA, LIE_Contextuality=NA, LIE_Negativity=NA),
      estimate_link(model_dimensional, target="LIE_Ability") %>%
        mutate(LIE_Frequency = NA, LIE_Contextuality=NA, LIE_Negativity=NA),
      estimate_link(model_dimensional, target="LIE_Contextuality") %>%
        mutate(LIE_Frequency = NA, LIE_Ability=NA, LIE_Negativity=NA),
      estimate_link(model_dimensional, target="LIE_Negativity") %>%
        mutate(LIE_Frequency = NA, LIE_Contextuality=NA, LIE_Ability=NA)) %>%
  pivot_longer(cols=starts_with("LIE_"), names_to="Dimension", values_to = "Score") %>%
  mutate(Dimension = str_remove(Dimension, "LIE_"),
         Dimension = fct_relevel(Dimension, "Frequency", "Ability", "Negativity", "Contextuality")) %>%
  ggplot(aes(x = Score, y = Predicted)) +
  geom_ribbon(aes(ymin=CI_low, ymax=CI_high, fill=Dimension), alpha=0.1) +
  geom_line(aes(color=Dimension), size = 1) +
  geom_text(data = sig, aes(label = Text)) +
  theme_modern() +
  theme(strip.placement = "outside",
        strip.text = element_text(size=13, face="plain"),
        axis.title = element_text(size=13),
        axis.text = element_text(size=9),
        plot.title = element_text(face="bold", hjust = 0.5)) +
  ggtitle("Age") +
  ylab("\nAge") +
  xlab("") +
  scale_color_manual(values=c("Frequency"="#4CAF50", "Ability"= "#2196F3", "Negativity"="#E91E63", "Contextuality"="#FF9800"), name = "Dimensions", guide=FALSE) +
   scale_fill_manual(values=c("Frequency"="#4CAF50", "Ability"= "#2196F3", "Negativity"="#E91E63", "Contextuality"="#FF9800"), name = "Dimensions", guide=FALSE) +
  facet_wrap(~Dimension, scales="free_x", strip.position = "bottom")

Education

model_profile <- stan_lmer(Education ~ LIE_Profile + Age + (1|Sex), data = df, refresh = 0, seed=333)
model_dimensional <- stan_lmer(Education ~ LIE_Ability + LIE_Frequency + LIE_Contextuality + LIE_Negativity + Age + (1|Sex), data = df, refresh = 0, seed=333)

performance::compare_performance(model_dimensional, model_profile)
Model Type ELPD ELPD_SE LOOIC LOOIC_SE WAIC R2 R2_marginal R2_adjusted RMSE Sigma
model_dimensional stanreg -1502 33 3005 65 3005 0.24 0.24 0.22 1.7 1.8
model_profile stanreg -1499 33 2997 66 2997 0.25 0.25 0.23 1.7 1.7
parameters::parameters_table(model_parameters(model_profile))
Parameter Median 89% CI pd % in ROPE Rhat ESS Prior
1 (Intercept) 6.75 [ 6.07, 7.32] 100% 0% 1.008 842.91 Normal (3.51 +- 5.01)
3 LIE_ProfileTrickster -0.36 [-0.58, -0.12] 99.52% 13.70% 1.000 2391.72 Normal (0.00 +- 10.51)
4 LIE_ProfileVirtuous 0.36 [ 0.08, 0.61] 98.62% 15.65% 1.000 2307.13 Normal (0.00 +- 11.90)
2 Age -0.13 [-0.14, -0.11] 100% 100% 1.001 2628.67 Normal (0.00 +- 0.65)
parameters::parameters_table(model_parameters(model_dimensional))
Parameter Median 89% CI pd % in ROPE Rhat ESS Prior
1 (Intercept) 6.73 [ 5.74, 8.25] 100% 0% 1.732 8.87 Normal (3.51 +- 5.01)
3 LIE_Ability -0.07 [-0.12, -0.01] 94.50% 99.98% 1.098 44.35 Normal (0.00 +- 2.16)
5 LIE_Frequency -0.08 [-0.16, 0.00] 96.40% 99.08% 1.001 2072.94 Normal (0.00 +- 2.69)
4 LIE_Contextuality 0.06 [-0.03, 0.15] 82.33% 99.58% 1.071 61.39 Normal (0.00 +- 3.75)
6 LIE_Negativity 0.01 [-0.10, 0.14] 57.57% 99.02% 1.019 658.49 Normal (0.00 +- 3.81)
2 Age -0.12 [-0.14, -0.11] 100% 100% 1.122 37.06 Normal (0.00 +- 0.65)
model_profile %>%
  estimate_means() %>%
  mutate(LIE_Profile = fct_relevel(LIE_Profile, "Trickster", "Average", "Virtuous")) %>%
  ggplot(aes(x = LIE_Profile, y = Mean, color = LIE_Profile)) +
  geom_line(aes(group = 1), size = 1) +
  geom_pointrange(aes(ymin = CI_low, ymax = CI_high), size = 1) +
  theme_modern() +
  scale_color_manual(values = colors_cluster, guide = FALSE) +
  ylab("Education (in years)") +
  xlab("Deception Profile")

Income

model_dimensional <- stan_lmer(Income ~ LIE_Ability + LIE_Frequency + LIE_Contextuality + LIE_Negativity + Age + Education + (1|Sex), data = df, refresh = 0, seed=333)
model_profile <- stan_lmer(Income ~ LIE_Profile + Age + Education + (1|Sex), data = df, refresh = 0, seed=333)

performance::compare_performance(model_dimensional, model_profile)
Model Type ELPD ELPD_SE LOOIC LOOIC_SE WAIC R2 R2_marginal R2_adjusted RMSE Sigma
model_dimensional stanreg -6464 138 12928 277 12951 0.04 0.04 0.01 4276 4307
model_profile stanreg -6468 142 12937 284 12950 0.04 0.04 0.01 4284 4302
parameters::parameters_table(model_parameters(model_profile))
Parameter Median 89% CI pd % in ROPE Rhat ESS Prior
1 (Intercept) -764.71 [-2488.52, 1151.07] 75.40% 25.97% 1.009 677.57 Normal (2806.25 +- 10895.43)
4 LIE_ProfileTrickster 418.98 [ -197.34, 1033.15] 86.62% 50.58% 1.001 2800.34 Normal (0.00 +- 22787.22)
5 LIE_ProfileVirtuous -373.30 [-1055.98, 381.52] 79.83% 51.70% 1.001 2707.16 Normal (0.00 +- 26137.92)
2 Age 74.38 [ 36.52, 118.91] 99.92% 100% 1.000 2149.66 Normal (0.00 +- 1404.88)
3 Education 434.89 [ 279.49, 584.29] 100% 50.32% 1.000 2468.65 Normal (0.00 +- 5456.14)
parameters::parameters_table(model_parameters(model_dimensional))
Parameter Median 89% CI pd % in ROPE Rhat ESS Prior
1 (Intercept) -620.75 [-2367.14, 1347.68] 73.25% 26.97% 1.003 1081.66 Normal (2806.25 +- 10895.43)
4 LIE_Ability 189.56 [ 28.94, 342.75] 97.12% 99.67% 1.001 2633.73 Normal (0.00 +- 4714.92)
6 LIE_Frequency 38.13 [ -173.63, 239.24] 60.92% 99.88% 1.000 2593.13 Normal (0.00 +- 5763.34)
5 LIE_Contextuality -165.66 [ -389.59, 90.37] 85.88% 96.83% 1.000 2905.98 Normal (0.00 +- 8123.93)
7 LIE_Negativity 16.91 [ -282.01, 331.21] 53.25% 97.35% 1.000 2615.01 Normal (0.00 +- 8156.44)
2 Age 74.16 [ 33.21, 113.12] 99.80% 100% 1.000 3135.67 Normal (0.00 +- 1404.88)
3 Education 436.76 [ 279.41, 583.97] 100% 49.53% 1.001 2656.01 Normal (0.00 +- 5456.14)
model_profile %>%
  estimate_means() %>%
  mutate(LIE_Profile = fct_relevel(LIE_Profile, "Trickster", "Average", "Virtuous")) %>%
  ggplot(aes(x = LIE_Profile, y = Mean, color = LIE_Profile)) +
  geom_line(aes(group = 1), size = 1) +
  geom_pointrange(aes(ymin = CI_low, ymax = CI_high), size = 1) +
  theme_modern() +
  scale_color_manual(values = colors_cluster, guide = FALSE) +
  ylab("Income") +
  xlab("Deception Profile")

sig <- model_parameters(model_dimensional)[2:5,] %>%
  select(Parameter, pd) %>%
  mutate(Dimension = stringr::str_remove(Parameter, "LIE_"),
         Text = format_pd(pd, stars_only=TRUE),
         Predicted = 4500,
         Score = df %>%
           select(one_of(Parameter)) %>%
           summarise_all(function(x) {mean(range(x))}) %>%
           t()) %>%
  mutate(Dimension = fct_relevel(Dimension, "Frequency", "Ability", "Negativity", "Contextuality"))

p_income <- rbind(estimate_link(model_dimensional, target="LIE_Ability") %>%
        mutate(LIE_Frequency = NA, LIE_Contextuality=NA, LIE_Negativity=NA),
      estimate_link(model_dimensional, target="LIE_Frequency") %>%
        mutate(LIE_Ability = NA, LIE_Contextuality=NA, LIE_Negativity=NA),
      estimate_link(model_dimensional, target="LIE_Contextuality") %>%
        mutate(LIE_Frequency = NA, LIE_Ability=NA, LIE_Negativity=NA),
      estimate_link(model_dimensional, target="LIE_Negativity") %>%
        mutate(LIE_Frequency = NA, LIE_Contextuality=NA, LIE_Ability=NA)) %>%
  pivot_longer(cols=starts_with("LIE_"), names_to="Dimension", values_to = "Score") %>%
  mutate(Dimension = str_remove(Dimension, "LIE_"),
         Dimension = fct_relevel(Dimension, "Frequency", "Ability", "Negativity", "Contextuality")) %>%
  ggplot(aes(x = Score, y = Predicted)) +
  geom_ribbon(aes(ymin=CI_low, ymax=CI_high, fill=Dimension), alpha=0.1) +
  geom_line(aes(color=Dimension), size = 1) +
  geom_text(data = sig, aes(label = Text)) +
  theme_modern() +
  theme(strip.placement = "outside",
        strip.text = element_text(size=13, face="plain"),
        axis.title = element_text(size=13),
        axis.text = element_text(size=9),
        plot.title = element_text(face="bold", hjust = 0.5)) +
  ggtitle("Income") +
  ylab("Income (in SGD per capita)") +
  xlab("") +
  scale_color_manual(values=c("Ability"= "#2196F3", "Frequency"="#4CAF50", "Negativity"="#E91E63", "Contextuality"="#FF9800"), name = "Dimensions", guide=FALSE) +
   scale_fill_manual(values=c("Ability"= "#2196F3", "Frequency"="#4CAF50", "Negativity"="#E91E63", "Contextuality"="#FF9800"), name = "Dimensions", guide=FALSE) +
  facet_wrap(~Dimension, scales="free_x", strip.position = "bottom")

Religion

model_dimensional <- stan_lmer(Religion_Faith ~ LIE_Ability + LIE_Frequency + LIE_Contextuality + LIE_Negativity + (1|Religion_Type), data = dplyr::filter(df, !is.na(Religion_Faith)), refresh = 0, seed=333)
model_profile <- stan_lmer(Religion_Faith ~ LIE_Profile + (1|Religion_Type), data = dplyr::filter(df, !is.na(Religion_Faith)), refresh = 0, seed=333)

performance::compare_performance(model_dimensional, model_profile)
Model Type ELPD ELPD_SE LOOIC LOOIC_SE WAIC R2 R2_marginal R2_adjusted RMSE Sigma
model_dimensional stanreg -1621 17 3242 34 3242 0.41 0.09 0.40 2.2 2.3
model_profile stanreg -1641 17 3282 33 3282 0.38 0.03 0.37 2.3 2.3
parameters::parameters_table(model_parameters(model_profile))
Parameter Median 89% CI pd % in ROPE Rhat ESS Prior
(Intercept) 4.39 [ 2.99, 5.78] 99.98% 0.02% 1.003 853.87 Normal (4.02 +- 7.35)
LIE_ProfileTrickster -0.37 [-0.68, -0.07] 97.42% 34.88% 1.000 3409.34 Normal (0.00 +- 15.40)
LIE_ProfileVirtuous 0.67 [ 0.34, 1.05] 99.85% 4.42% 0.999 3320.64 Normal (0.00 +- 17.58)
parameters::parameters_table(model_parameters(model_dimensional))
Parameter Median 89% CI pd % in ROPE Rhat ESS Prior
1 (Intercept) 4.42 [ 3.08, 5.54] 100% 0% 1.008 810.47 Normal (4.02 +- 7.35)
2 LIE_Ability -0.01 [-0.09, 0.07] 59.00% 100% 0.999 4395.75 Normal (0.00 +- 3.19)
4 LIE_Frequency 0.25 [ 0.14, 0.36] 100% 77.08% 1.001 3469.94 Normal (0.00 +- 3.96)
3 LIE_Contextuality -0.25 [-0.37, -0.12] 99.98% 72.08% 1.000 4166.38 Normal (0.00 +- 5.47)
5 LIE_Negativity 0.53 [ 0.38, 0.68] 100% 0.75% 1.000 3290.13 Normal (0.00 +- 5.57)
model_profile %>%
  estimate_means() %>%
  mutate(LIE_Profile = fct_relevel(LIE_Profile, "Trickster", "Average", "Virtuous")) %>%
  ggplot(aes(x = LIE_Profile, y = Mean, color = LIE_Profile)) +
  geom_line(aes(group = 1), size = 1) +
  geom_pointrange(aes(ymin = CI_low, ymax = CI_high), size = 1) +
  theme_modern() +
  scale_color_manual(values = colors_cluster, guide = FALSE) +
  ylab("Faith") +
  xlab("Deception Profile")

sig <- model_parameters(model_dimensional)[-1,] %>%
  select(Parameter, pd) %>%
  mutate(Dimension = stringr::str_remove(Parameter, "LIE_"),
         Text = format_pd(pd, stars_only=TRUE),
         Predicted = 6.5,
         Score = dplyr::filter(df, !is.na(Religion_Faith)) %>%
           select(one_of(Parameter)) %>%
           summarise_all(function(x) {mean(range(x))}) %>%
           t()) %>%
  mutate(Dimension = fct_relevel(Dimension, "Frequency", "Ability", "Negativity", "Contextuality"))


p_religion <- rbind(estimate_link(model_dimensional, target="LIE_Ability") %>%
        mutate(LIE_Frequency = NA, LIE_Contextuality=NA, LIE_Negativity=NA),
      estimate_link(model_dimensional, target="LIE_Frequency") %>%
        mutate(LIE_Ability = NA, LIE_Contextuality=NA, LIE_Negativity=NA),
      estimate_link(model_dimensional, target="LIE_Contextuality") %>%
        mutate(LIE_Frequency = NA, LIE_Ability=NA, LIE_Negativity=NA),
      estimate_link(model_dimensional, target="LIE_Negativity") %>%
        mutate(LIE_Frequency = NA, LIE_Contextuality=NA, LIE_Ability=NA)) %>%
  pivot_longer(cols=starts_with("LIE_"), names_to="Dimension", values_to = "Score") %>%
  mutate(Dimension = str_remove(Dimension, "LIE_"),
         Dimension = fct_relevel(Dimension, "Frequency", "Ability", "Negativity", "Contextuality")) %>%
  ggplot(aes(x = Score, y = Predicted)) +
  geom_ribbon(aes(ymin=CI_low, ymax=CI_high, fill=Dimension), alpha=0.1) +
  geom_line(aes(color=Dimension), size = 1) +
  theme_modern() +
  theme(strip.placement = "outside",
        strip.text = element_text(size=13, face="plain"),
        axis.title = element_text(size=13),
        axis.text = element_text(size=9),
        plot.title = element_text(face="bold", hjust = 0.5)) +
  geom_text(data = sig, aes(label = Text)) +
  ggtitle("Religion") +
  ylab("\nFaith") +
  xlab("") +
  scale_color_manual(values=c("Ability"= "#2196F3", "Frequency"="#4CAF50", "Negativity"="#E91E63", "Contextuality"="#FF9800"), name = "Dimensions", guide=FALSE) +
   scale_fill_manual(values=c("Ability"= "#2196F3", "Frequency"="#4CAF50", "Negativity"="#E91E63", "Contextuality"="#FF9800"), name = "Dimensions", guide=FALSE) +
  facet_wrap(~Dimension, scales="free_x", strip.position = "bottom")
# Combine plots
combine_plots <- cowplot::plot_grid(p_sex, p_age, p_income, p_religion, nrow=2)
ggsave("figures/demographics.png", combine_plots, height=figwidth, width=figwidth)

Number of Lies

Raw

df$Lying_Frequency <- (df$Lying_Frequency_Day + df$Lying_Frequency_Week / 7) / 2
outliers <- check_outliers(df$Lying_Frequency, method = "zscore", threshold = list("zscore" = stats::qnorm(p = 0.999)))
df$Lying_Frequency[outliers == 1] <- NA


p_freq1 <- df %>%
  filter(!is.na(Lying_Frequency)) %>%
  ggplot(aes(x = Lying_Frequency)) +
  geom_histogram(aes(y=..density.., fill = ..x..), binwidth = 1/7) +
  geom_line(data=estimate_density(df$Lying_Frequency, method = "kernSmooth"),
            aes(x = x, y = y), color = "#2196F3", size = 1.5) +
  scale_fill_gradient(low='#AD1457', high='#F48FB1', guide = FALSE) +
  ylab("Distribution of Participants") +
  xlab(expression(paste('Lying Frequency ', italic("(lies / day)"))))  +
  theme_modern() +
  theme(axis.text.y = element_blank())
library(ggforce)

df %>%
  filter(!is.na(Lying_Frequency)) %>%
  dplyr::select(starts_with("LIE"), Lying_Frequency) %>%
  ggplot(aes(x = .panel_x, y = .panel_y, fill = LIE_Profile, colour = LIE_Profile)) +
  geom_point(alpha = 1, shape = 16, size = 0.5) +
  geom_smooth(method = 'lm', formula = y ~ poly(x, 1), alpha = 0.1) +
  scale_color_manual(values = colors_cluster) +
  scale_fill_manual(values = colors_cluster) +
  ggforce::facet_matrix(cols = vars(LIE_Ability , LIE_Frequency, LIE_Negativity, LIE_Contextuality), rows = vars(Lying_Frequency)) +
  coord_cartesian(ylim = c(0, 5)) +
  theme_modern()

model_profile <- stan_glm(Lying_Frequency ~ LIE_Profile, data = df, refresh = 0, seed=333)
model_dimensional <- stan_glm(Lying_Frequency ~ LIE_Ability + LIE_Frequency + LIE_Contextuality + LIE_Negativity, data = df, refresh = 0, seed=333)

performance::compare_performance(model_dimensional, model_profile)
Model Type ELPD ELPD_SE LOOIC LOOIC_SE WAIC R2 R2_adjusted RMSE Sigma
model_dimensional stanreg -903 22 1807 44 1807 0.16 0.15 0.87 0.87
model_profile stanreg -918 21 1837 43 1837 0.12 0.11 0.89 0.89
parameters::parameters_table(model_parameters(model_profile))
Parameter Median 89% CI pd % in ROPE Rhat ESS Prior
(Intercept) 1.08 [ 0.99, 1.15] 100% 0% 1.000 4095.27 Normal (1.16 +- 2.36)
LIE_ProfileTrickster 0.51 [ 0.39, 0.64] 100% 0% 1.000 3650.96 Normal (0.00 +- 5.05)
LIE_ProfileVirtuous -0.35 [-0.49, -0.22] 100% 0.15% 0.999 4190.49 Normal (0.00 +- 5.52)
parameters::parameters_table(model_parameters(model_dimensional))
Parameter Median 89% CI pd % in ROPE Rhat ESS Prior
1 (Intercept) 1.18 [ 1.13, 1.23] 100% 0% 1.000 4102.80 Normal (1.16 +- 2.36)
2 LIE_Ability 7.38e-03 [-0.02, 0.04] 65.65% 100% 1.001 3097.72 Normal (0.00 +- 1.02)
4 LIE_Frequency 0.17 [ 0.13, 0.21] 100% 0.15% 1.000 3445.35 Normal (0.00 +- 1.31)
3 LIE_Contextuality 0.04 [ 0.00, 0.09] 94.23% 95.83% 1.000 3503.00 Normal (0.00 +- 1.76)
5 LIE_Negativity -0.03 [-0.09, 0.03] 78.77% 94.45% 1.001 3273.09 Normal (0.00 +- 1.83)
p_freq2 <- model_dimensional %>%
  estimate_link(target = "LIE_Frequency", length = 10, smooth_strength = 0) %>%
  ggplot(aes(x = LIE_Frequency, y = Predicted)) +
  geom_point2(data = df, aes(y = Lying_Frequency, color = Lying_Frequency), size = 4, alpha=0.7) +
  geom_ribbon(aes(ymin = CI_low, ymax = CI_high), alpha = 0.2) +
  geom_line(size = 1.5) +
  scale_color_gradient(low='#AD1457', high='#F48FB1', guide = FALSE) +
  theme_modern() +
  ylab("Absolute Lying Frequency (lies / day)") +
  xlab("LIE - Frequency") +
  theme(plot.margin = unit(c(5.5, 0, 5.5, 5.5), "pt"))
# Combine plots
cowplot::plot_grid(p_freq2,
                   p_freq1 +
                     coord_flip() +
                     xlab("") +
                     ylab("") +
                     theme(axis.line = element_blank(),
                           axis.text.x = element_blank(),
                           axis.title.y = element_blank(),
                           axis.line.y = element_blank(),
                           axis.ticks.y=element_blank(),
                           plot.margin = unit(c(0, 0, 10, -20), "pt")),
                   nrow=1, rel_widths = c(0.75, 0.25))

Adjusted

df$Lying_Frequency_Adjusted <- effectsize::adjust(df, select = "Lying_Frequency", effect = c("BIDR_ImpressionManagement", "BIDR_SelfDeceptiveEnhancement"))$Lying_Frequency
df$Lying_Frequency_Adjusted <- df$Lying_Frequency_Adjusted + abs(min(df$Lying_Frequency_Adjusted, na.rm=TRUE))


p_freq1adj <- df %>%
  filter(!is.na(Lying_Frequency_Adjusted)) %>%
  ggplot(aes(x = Lying_Frequency_Adjusted)) +
  geom_histogram(aes(y=..density.., fill = ..x..), binwidth = 1/7) +
  geom_line(data=estimate_density(df$Lying_Frequency_Adjusted, method = "kernSmooth"),
            aes(x = x, y = y), color = "red", size = 1.5) +
  scale_fill_gradient(low='#1A237E', high='#2196F3', guide = FALSE) +
  ylab("Distribution of Participants") +
  xlab(expression(paste('Lying Frequency ', italic("(lies / day)"))))  +
  theme_modern() +
  theme(axis.text.y = element_blank())
library(ggforce)

df %>%
  filter(!is.na(Lying_Frequency_Adjusted)) %>%
  dplyr::select(starts_with("LIE"), Lying_Frequency_Adjusted) %>%
  ggplot(aes(x = .panel_x, y = .panel_y, fill = LIE_Profile, colour = LIE_Profile)) +
  geom_point(alpha = 1, shape = 16, size = 0.5) +
  geom_smooth(method = 'lm', formula = y ~ poly(x, 1), alpha = 0.1) +
  scale_color_manual(values = colors_cluster) +
  scale_fill_manual(values = colors_cluster) +
  ggforce::facet_matrix(cols = vars(LIE_Ability , LIE_Frequency, LIE_Negativity, LIE_Contextuality), rows = vars(Lying_Frequency_Adjusted)) +
  coord_cartesian(ylim = c(0, 5)) +
  theme_modern()

model_profile <- stan_glm(Lying_Frequency_Adjusted ~ LIE_Profile, data = df, refresh = 0, seed=333)
model_dimensional <- stan_glm(Lying_Frequency_Adjusted ~ LIE_Ability + LIE_Frequency + LIE_Contextuality + LIE_Negativity, data = df, refresh = 0, seed=333)

performance::compare_performance(model_dimensional, model_profile)
Model Type ELPD ELPD_SE LOOIC LOOIC_SE WAIC R2 R2_adjusted RMSE Sigma
model_dimensional stanreg -913 22 1825 44 1825 0.10 0.08 0.88 0.88
model_profile stanreg -919 21 1838 43 1838 0.07 0.07 0.89 0.89
parameters::parameters_table(model_parameters(model_profile))
Parameter Median 89% CI pd % in ROPE Rhat ESS Prior
(Intercept) 1.47 [ 1.38, 1.54] 100% 0% 0.999 4030.29 Normal (1.54 +- 2.31)
LIE_ProfileTrickster 0.41 [ 0.28, 0.53] 100% 0% 0.999 3964.79 Normal (0.00 +- 4.94)
LIE_ProfileVirtuous -0.24 [-0.38, -0.11] 99.85% 3.15% 1.000 4097.41 Normal (0.00 +- 5.39)
parameters::parameters_table(model_parameters(model_dimensional))
Parameter Median 89% CI pd % in ROPE Rhat ESS Prior
1 (Intercept) 1.56 [ 1.51, 1.61] 100% 0% 1.000 4430.76 Normal (1.54 +- 2.31)
2 LIE_Ability 0.01 [-0.02, 0.04] 76.00% 100% 1.000 3546.49 Normal (0.00 +- 1.00)
4 LIE_Frequency 0.14 [ 0.10, 0.19] 100% 2.70% 1.000 3433.41 Normal (0.00 +- 1.28)
3 LIE_Contextuality 9.35e-03 [-0.04, 0.06] 62.45% 99.65% 1.000 3491.33 Normal (0.00 +- 1.72)
5 LIE_Negativity -7.34e-03 [-0.07, 0.06] 56.95% 97.55% 1.000 3332.26 Normal (0.00 +- 1.79)
p_freq2adj <- model_dimensional %>%
  estimate_link(target = "LIE_Frequency", length = 10, smooth_strength = 0) %>%
  ggplot(aes(x = LIE_Frequency, y = Predicted)) +
  geom_point2(data = df, aes(y = Lying_Frequency_Adjusted, color = Lying_Frequency_Adjusted), size = 4, alpha=0.7) +
  geom_ribbon(aes(ymin = CI_low, ymax = CI_high), alpha = 0.2) +
  geom_line(size = 1.5) +
  scale_color_gradient(low='#1A237E', high='#2196F3', guide = FALSE) +
  theme_modern() +
  ylab("Absolute Lying Frequency (lies / day)") +
  xlab("LIE - Frequency") +
  theme(plot.margin = unit(c(5.5, 0, 5.5, 5.5), "pt"))
# Combine plots
p <- cowplot::plot_grid(p_freq2adj,
                   p_freq1adj +
                     coord_flip() +
                     xlab("") +
                     ylab("") +
                     theme(axis.line = element_blank(),
                           axis.text.x = element_blank(),
                           axis.title.y = element_blank(),
                           axis.line.y = element_blank(),
                           axis.ticks.y=element_blank(),
                           plot.margin = unit(c(0, 0, 10, -20), "pt")),
                   nrow=1, rel_widths = c(0.75, 0.25))

ggsave("figures/figure_absolutelying_adjusted.png", p, height=figheight, width=figwidth)

Social Desirability (BIDR)

Utility Functions

library(ggraph)
library(tidygraph)

colors_nodes <- c("LIE"= "#9C27B0",
                  "Psychopathy" = "#f44336",
                  "Narcissism" = "#FF9800",
                  "Pathological Personality" = "#FFC107",
                  "Normal Personality" = "#4CAF50",
                  "Social Desirability" = "#795548",
                  "Light Triad" = "#2196F3",
                  "Impulsivity" = "#673AB7",
                  "Emotion Regulation" = "#E91E63",
                  "Interoception" = "#b71c1c")

# convenience function
create_ggm <- function(data, title = "Pychopathy (TRIMP)", title_size=22, label_edges = TRUE, node_size=32, text_size=5.5, layout="kk", seed=333, bend=0.2){
  set.seed(seed)

  label_edges <- ifelse(rep_len(label_edges, length.out=nrow(data$edges)), insight::format_value(data$edges$r), "")

  data %>%
    ggraph(layout = layout) +
    geom_edge_arc(aes(colour=r, edge_width = abs(r), label = label_edges),
                  strength=bend,
                  angle_calc = 'along',
                  label_dodge = unit(3.5, 'mm'),
                  check_overlap = FALSE) +
    geom_node_point(aes(colour = Questionnaire), size=node_size) +
    geom_node_text(aes(label = name), colour="white", check_overlap = FALSE, repel = FALSE, size=text_size, fontface="bold") +
    scale_edge_color_gradient2(low = "#d50000", high = "#00C853") +
    scale_color_manual(values = colors_nodes) +
    theme_graph() +
    guides(edge_width = FALSE,
           edge_color = FALSE,
           colour = FALSE) +
    scale_x_continuous(expand = expand_scale(c(.15, .15))) +
    scale_y_continuous(expand = expand_scale(c(.15, .15))) +
    theme(plot.title = element_text(hjust = 0.5, face="bold", size = title_size),
          plot.margin = unit(c(0, 0, 0, 0), "cm")) +
    ggtitle(title)
}

Gaussian Graphical Model

cor_bidr <- correlation::correlation(
  dplyr::select(df, dplyr::starts_with("LIE"), dplyr::starts_with("BIDR"), -BIDR_General),
  partial = TRUE, p_adjust = "none")

parameters::parameters_table(cor_bidr)
Parameter1 Parameter2 r 95% CI t(760) p Method n_Obs
LIE_Frequency LIE_Ability 0.27 [ 0.20, 0.34] 7.78 < .001 Pearson 762
LIE_Frequency LIE_Negativity -0.55 [-0.60, -0.50] -18.09 < .001 Pearson 762
LIE_Frequency LIE_Contextuality -0.17 [-0.23, -0.10] -4.63 < .001 Pearson 762
LIE_Frequency BIDR_SelfDeceptiveEnhancement -0.20 [-0.27, -0.13] -5.62 < .001 Pearson 762
LIE_Frequency BIDR_ImpressionManagement -0.13 [-0.20, -0.06] -3.51 < .001 Pearson 762
LIE_Ability LIE_Negativity -0.17 [-0.23, -0.10] -4.64 < .001 Pearson 762
LIE_Ability LIE_Contextuality 0.34 [ 0.27, 0.40] 9.92 < .001 Pearson 762
LIE_Ability BIDR_SelfDeceptiveEnhancement 0.21 [ 0.14, 0.28] 5.98 < .001 Pearson 762
LIE_Ability BIDR_ImpressionManagement -0.08 [-0.15, -0.01] -2.21 0.027 Pearson 762
LIE_Negativity LIE_Contextuality -0.26 [-0.33, -0.20] -7.54 < .001 Pearson 762
LIE_Negativity BIDR_SelfDeceptiveEnhancement -0.07 [-0.14, 0.00] -1.90 0.057 Pearson 762
LIE_Negativity BIDR_ImpressionManagement 0.12 [ 0.05, 0.19] 3.35 < .001 Pearson 762
LIE_Contextuality BIDR_SelfDeceptiveEnhancement -0.11 [-0.18, -0.04] -2.95 0.003 Pearson 762
LIE_Contextuality BIDR_ImpressionManagement -0.17 [-0.24, -0.10] -4.80 < .001 Pearson 762
BIDR_SelfDeceptiveEnhancement BIDR_ImpressionManagement 0.26 [ 0.20, 0.33] 7.50 < .001 Pearson 762
graphdata_bidr <- cor_bidr %>%
  filter(p < .001) %>%
  tidygraph::as_tbl_graph() %>%
  as.list()

graphdata_bidr$nodes$Questionnaire <- ifelse(stringr::str_detect(graphdata_bidr$nodes$name, "LIE_"),
                               "LIE", "Social Desirability")
graphdata_bidr$nodes$name <- stringr::str_remove(graphdata_bidr$nodes$name, "LIE_|BIDR_")
graphdata_bidr$nodes$name <- stringr::str_replace(graphdata_bidr$nodes$name, "fD", "f-D")
graphdata_bidr$nodes$name <- stringr::str_replace(graphdata_bidr$nodes$name, "nM", "n\nM")
graphdata_bidr$nodes$name <- stringr::str_replace(graphdata_bidr$nodes$name, "eE", "e\nE")

ggm_bidr <- create_ggm(graphdata_bidr, title = "Social Desirability", layout="sugiyama")
ggm_bidr

After controlling for social desirability, it seems that the relationship between frequency and contextuality changed from being positive to negative. The more people lie (likely representing a lack of control), and the less flexible and insensitive to the context they are.

Adjust for Social Desirability

lie <- df[names(dplyr::select(df, dplyr::starts_with("LIE"), -LIE_Profile))]
df[names(lie)] <- effectsize::adjust(data = cbind(lie, df[c("BIDR_ImpressionManagement", "BIDR_SelfDeceptiveEnhancement", "Age", "Sex")]),
                                     effect = c("BIDR_ImpressionManagement", "BIDR_SelfDeceptiveEnhancement", "Age", "Sex"),
                                     multilevel = TRUE)[names(lie)]

Psychopathy (TRIMP)

cor_trimp <- correlation::correlation(
  dplyr::select(df, dplyr::starts_with("LIE"), -LIE_Profile, TRIMP_Boldness, TRIMP_Meanness, TRIMP_Disinhibition),
  partial = TRUE, p_adjust = "none")

parameters::parameters_table(cor_trimp)
Parameter1 Parameter2 r 95% CI t(755) p Method n_Obs
LIE_Frequency LIE_Ability 0.26 [ 0.19, 0.33] 7.44 < .001 Pearson 757
LIE_Frequency LIE_Negativity -0.53 [-0.58, -0.48] -17.25 < .001 Pearson 757
LIE_Frequency LIE_Contextuality -0.15 [-0.22, -0.08] -4.17 < .001 Pearson 757
LIE_Frequency TRIMP_Boldness 4.17e-04 [-0.07, 0.07] 0.01 0.991 Pearson 757
LIE_Frequency TRIMP_Meanness -0.03 [-0.10, 0.05] -0.71 0.476 Pearson 757
LIE_Frequency TRIMP_Disinhibition 0.23 [ 0.17, 0.30] 6.62 < .001 Pearson 757
LIE_Ability LIE_Negativity -0.15 [-0.22, -0.08] -4.06 < .001 Pearson 757
LIE_Ability LIE_Contextuality 0.34 [ 0.28, 0.41] 10.09 < .001 Pearson 757
LIE_Ability TRIMP_Boldness 0.23 [ 0.16, 0.30] 6.50 < .001 Pearson 757
LIE_Ability TRIMP_Meanness -0.02 [-0.09, 0.05] -0.53 0.596 Pearson 757
LIE_Ability TRIMP_Disinhibition 0.04 [-0.04, 0.11] 0.99 0.325 Pearson 757
LIE_Negativity LIE_Contextuality -0.26 [-0.33, -0.20] -7.53 < .001 Pearson 757
LIE_Negativity TRIMP_Boldness 0.03 [-0.04, 0.10] 0.74 0.461 Pearson 757
LIE_Negativity TRIMP_Meanness -0.19 [-0.26, -0.12] -5.31 < .001 Pearson 757
LIE_Negativity TRIMP_Disinhibition 0.15 [ 0.08, 0.22] 4.09 < .001 Pearson 757
LIE_Contextuality TRIMP_Boldness -0.08 [-0.15, -0.01] -2.25 0.024 Pearson 757
LIE_Contextuality TRIMP_Meanness -0.03 [-0.10, 0.04] -0.79 0.431 Pearson 757
LIE_Contextuality TRIMP_Disinhibition -0.01 [-0.08, 0.06] -0.36 0.719 Pearson 757
TRIMP_Boldness TRIMP_Meanness 0.29 [ 0.22, 0.35] 8.18 < .001 Pearson 757
TRIMP_Boldness TRIMP_Disinhibition -0.30 [-0.36, -0.23] -8.60 < .001 Pearson 757
TRIMP_Meanness TRIMP_Disinhibition 0.62 [ 0.58, 0.66] 21.84 < .001 Pearson 757
graphdata_trimp <- cor_trimp %>%
  filter(p < .001) %>%
  tidygraph::as_tbl_graph() %>%
  as.list()

graphdata_trimp$nodes$Questionnaire <- ifelse(stringr::str_detect(graphdata_trimp$nodes$name, "LIE_"),
                               "LIE", "Psychopathy")
graphdata_trimp$nodes$name <- stringr::str_remove(graphdata_trimp$nodes$name, "LIE_|TRIMP_")


create_ggm(graphdata_trimp, title = "Pychopathy")

Narcissism (FFNI)

cor_ffni <- correlation::correlation(
  dplyr::select(df, dplyr::starts_with("LIE"), dplyr::starts_with("FFNI"), -FFNI_General),
  partial = TRUE, p_adjust = "none")

parameters::parameters_table(cor_ffni)
Parameter1 Parameter2 r 95% CI t(755) p Method n_Obs
LIE_Frequency LIE_Ability 0.24 [ 0.17, 0.31] 6.80 < .001 Pearson 757
LIE_Frequency LIE_Negativity -0.54 [-0.59, -0.49] -17.68 < .001 Pearson 757
LIE_Frequency LIE_Contextuality -0.17 [-0.24, -0.10] -4.72 < .001 Pearson 757
LIE_Frequency FFNI_AcclaimSeeking 0.02 [-0.05, 0.09] 0.46 0.649 Pearson 757
LIE_Frequency FFNI_Distrust -0.03 [-0.10, 0.04] -0.78 0.436 Pearson 757
LIE_Frequency FFNI_Entitlement 0.08 [ 0.01, 0.15] 2.33 0.020 Pearson 757
LIE_Frequency FFNI_Exploitativeness -0.01 [-0.08, 0.06] -0.30 0.761 Pearson 757
LIE_Frequency FFNI_Indifference 0.06 [-0.01, 0.13] 1.67 0.096 Pearson 757
LIE_Frequency FFNI_LackOfEmpathy 0.10 [ 0.03, 0.17] 2.84 0.005 Pearson 757
LIE_Frequency FFNI_Manipulativeness -9.12e-03 [-0.08, 0.06] -0.25 0.802 Pearson 757
LIE_Frequency FFNI_NeedForAdmiration 0.10 [ 0.03, 0.17] 2.69 0.007 Pearson 757
LIE_Frequency FFNI_ThrillSeeking 0.04 [-0.03, 0.11] 1.01 0.312 Pearson 757
LIE_Ability LIE_Negativity -0.17 [-0.24, -0.10] -4.81 < .001 Pearson 757
LIE_Ability LIE_Contextuality 0.33 [ 0.27, 0.39] 9.66 < .001 Pearson 757
LIE_Ability FFNI_AcclaimSeeking -0.03 [-0.10, 0.04] -0.74 0.459 Pearson 757
LIE_Ability FFNI_Distrust 0.06 [-0.01, 0.13] 1.62 0.105 Pearson 757
LIE_Ability FFNI_Entitlement -0.02 [-0.09, 0.05] -0.63 0.527 Pearson 757
LIE_Ability FFNI_Exploitativeness -0.12 [-0.19, -0.05] -3.22 0.001 Pearson 757
LIE_Ability FFNI_Indifference -0.01 [-0.09, 0.06] -0.39 0.696 Pearson 757
LIE_Ability FFNI_LackOfEmpathy -0.05 [-0.12, 0.02] -1.29 0.198 Pearson 757
LIE_Ability FFNI_Manipulativeness 0.35 [ 0.29, 0.42] 10.42 < .001 Pearson 757
LIE_Ability FFNI_NeedForAdmiration 1.70e-03 [-0.07, 0.07] 0.05 0.963 Pearson 757
LIE_Ability FFNI_ThrillSeeking 0.03 [-0.04, 0.10] 0.77 0.442 Pearson 757
LIE_Negativity LIE_Contextuality -0.26 [-0.33, -0.20] -7.53 < .001 Pearson 757
LIE_Negativity FFNI_AcclaimSeeking 0.10 [ 0.03, 0.17] 2.81 0.005 Pearson 757
LIE_Negativity FFNI_Distrust -8.72e-03 [-0.08, 0.06] -0.24 0.811 Pearson 757
LIE_Negativity FFNI_Entitlement 0.09 [ 0.02, 0.16] 2.52 0.012 Pearson 757
LIE_Negativity FFNI_Exploitativeness -0.13 [-0.20, -0.05] -3.48 < .001 Pearson 757
LIE_Negativity FFNI_Indifference 0.04 [-0.03, 0.11] 1.12 0.261 Pearson 757
LIE_Negativity FFNI_LackOfEmpathy -2.62e-03 [-0.07, 0.07] -0.07 0.943 Pearson 757
LIE_Negativity FFNI_Manipulativeness 0.06 [-0.01, 0.13] 1.73 0.083 Pearson 757
LIE_Negativity FFNI_NeedForAdmiration 0.10 [ 0.03, 0.17] 2.88 0.004 Pearson 757
LIE_Negativity FFNI_ThrillSeeking -0.02 [-0.09, 0.05] -0.49 0.627 Pearson 757
LIE_Contextuality FFNI_AcclaimSeeking 0.11 [ 0.04, 0.18] 2.98 0.003 Pearson 757
LIE_Contextuality FFNI_Distrust 0.02 [-0.05, 0.09] 0.55 0.581 Pearson 757
LIE_Contextuality FFNI_Entitlement -0.04 [-0.11, 0.04] -0.97 0.330 Pearson 757
LIE_Contextuality FFNI_Exploitativeness 0.04 [-0.04, 0.11] 0.98 0.327 Pearson 757
LIE_Contextuality FFNI_Indifference 0.04 [-0.03, 0.12] 1.22 0.224 Pearson 757
LIE_Contextuality FFNI_LackOfEmpathy 9.99e-03 [-0.06, 0.08] 0.27 0.784 Pearson 757
LIE_Contextuality FFNI_Manipulativeness -0.11 [-0.18, -0.03] -2.91 0.004 Pearson 757
LIE_Contextuality FFNI_NeedForAdmiration 0.09 [ 0.02, 0.16] 2.47 0.014 Pearson 757
LIE_Contextuality FFNI_ThrillSeeking 0.03 [-0.05, 0.10] 0.72 0.473 Pearson 757
FFNI_AcclaimSeeking FFNI_Distrust 0.05 [-0.02, 0.12] 1.36 0.173 Pearson 757
FFNI_AcclaimSeeking FFNI_Entitlement 0.12 [ 0.05, 0.19] 3.38 < .001 Pearson 757
FFNI_AcclaimSeeking FFNI_Exploitativeness 5.27e-03 [-0.07, 0.08] 0.14 0.885 Pearson 757
FFNI_AcclaimSeeking FFNI_Indifference 0.05 [-0.02, 0.12] 1.49 0.137 Pearson 757
FFNI_AcclaimSeeking FFNI_LackOfEmpathy -0.15 [-0.22, -0.08] -4.30 < .001 Pearson 757
FFNI_AcclaimSeeking FFNI_Manipulativeness 0.20 [ 0.13, 0.27] 5.73 < .001 Pearson 757
FFNI_AcclaimSeeking FFNI_NeedForAdmiration -0.06 [-0.13, 0.01] -1.62 0.106 Pearson 757
FFNI_AcclaimSeeking FFNI_ThrillSeeking 0.17 [ 0.10, 0.24] 4.87 < .001 Pearson 757
FFNI_Distrust FFNI_Entitlement 0.08 [ 0.00, 0.15] 2.08 0.038 Pearson 757
FFNI_Distrust FFNI_Exploitativeness 0.18 [ 0.11, 0.25] 4.95 < .001 Pearson 757
FFNI_Distrust FFNI_Indifference 0.11 [ 0.04, 0.18] 3.12 0.002 Pearson 757
FFNI_Distrust FFNI_LackOfEmpathy 0.06 [-0.01, 0.14] 1.78 0.076 Pearson 757
FFNI_Distrust FFNI_Manipulativeness -0.06 [-0.13, 0.02] -1.52 0.129 Pearson 757
FFNI_Distrust FFNI_NeedForAdmiration 0.17 [ 0.10, 0.24] 4.83 < .001 Pearson 757
FFNI_Distrust FFNI_ThrillSeeking -0.04 [-0.11, 0.03] -1.06 0.288 Pearson 757
FFNI_Entitlement FFNI_Exploitativeness 0.28 [ 0.21, 0.34] 8.01 < .001 Pearson 757
FFNI_Entitlement FFNI_Indifference -0.03 [-0.10, 0.04] -0.73 0.467 Pearson 757
FFNI_Entitlement FFNI_LackOfEmpathy 0.24 [ 0.17, 0.31] 6.82 < .001 Pearson 757
FFNI_Entitlement FFNI_Manipulativeness 0.07 [ 0.00, 0.14] 1.95 0.052 Pearson 757
FFNI_Entitlement FFNI_NeedForAdmiration 0.12 [ 0.05, 0.19] 3.24 0.001 Pearson 757
FFNI_Entitlement FFNI_ThrillSeeking 0.07 [ 0.00, 0.14] 2.02 0.043 Pearson 757
FFNI_Exploitativeness FFNI_Indifference -0.06 [-0.13, 0.02] -1.52 0.129 Pearson 757
FFNI_Exploitativeness FFNI_LackOfEmpathy 0.24 [ 0.17, 0.31] 6.88 < .001 Pearson 757
FFNI_Exploitativeness FFNI_Manipulativeness 0.41 [ 0.35, 0.47] 12.39 < .001 Pearson 757
FFNI_Exploitativeness FFNI_NeedForAdmiration 0.07 [ 0.00, 0.14] 2.04 0.042 Pearson 757
FFNI_Exploitativeness FFNI_ThrillSeeking 0.06 [-0.02, 0.13] 1.52 0.130 Pearson 757
FFNI_Indifference FFNI_LackOfEmpathy 0.33 [ 0.27, 0.39] 9.67 < .001 Pearson 757
FFNI_Indifference FFNI_Manipulativeness 0.14 [ 0.07, 0.21] 3.87 < .001 Pearson 757
FFNI_Indifference FFNI_NeedForAdmiration -0.46 [-0.51, -0.40] -14.19 < .001 Pearson 757
FFNI_Indifference FFNI_ThrillSeeking 0.15 [ 0.08, 0.22] 4.21 < .001 Pearson 757
FFNI_LackOfEmpathy FFNI_Manipulativeness -0.04 [-0.11, 0.03] -1.07 0.287 Pearson 757
FFNI_LackOfEmpathy FFNI_NeedForAdmiration 0.02 [-0.05, 0.09] 0.52 0.606 Pearson 757
FFNI_LackOfEmpathy FFNI_ThrillSeeking 0.09 [ 0.01, 0.16] 2.36 0.018 Pearson 757
FFNI_Manipulativeness FFNI_NeedForAdmiration 5.52e-03 [-0.07, 0.08] 0.15 0.879 Pearson 757
FFNI_Manipulativeness FFNI_ThrillSeeking 0.13 [ 0.06, 0.20] 3.60 < .001 Pearson 757
FFNI_NeedForAdmiration FFNI_ThrillSeeking 0.05 [-0.02, 0.12] 1.39 0.165 Pearson 757
graphdata_ffni <- cor_ffni %>%
  filter(p < .001) %>%
  tidygraph::as_tbl_graph() %>%
  as.list()

graphdata_ffni$nodes$Questionnaire <- ifelse(stringr::str_detect(graphdata_ffni$nodes$name, "LIE_"),
                               "LIE", "Narcissism")
graphdata_ffni$nodes$name <- stringr::str_remove(graphdata_ffni$nodes$name, "LIE_|FFNI_")
graphdata_ffni$nodes$name <- stringr::str_replace(graphdata_ffni$nodes$name, "dForA", "d for\nA")
graphdata_ffni$nodes$name <- stringr::str_replace(graphdata_ffni$nodes$name, "mS", "m\nS")
graphdata_ffni$nodes$name <- stringr::str_replace(graphdata_ffni$nodes$name, "lS", "l\nS")
graphdata_ffni$nodes$name <- stringr::str_replace(graphdata_ffni$nodes$name, "kOfE", "k of\nE")


ggm_ffni <- create_ggm(graphdata_ffni, title = "Narcissism", node_size=38)
ggm_ffni

Normal Personality (IPIP6)

cor_ipip <- correlation::correlation(
  dplyr::select(df, dplyr::starts_with("LIE"), dplyr::starts_with("IPIP6")),
  partial = TRUE, p_adjust = "none")

parameters::parameters_table(cor_ipip)
Parameter1 Parameter2 r 95% CI t(755) p Method n_Obs
LIE_Frequency LIE_Ability 0.27 [ 0.20, 0.33] 7.58 < .001 Pearson 757
LIE_Frequency LIE_Negativity -0.52 [-0.57, -0.47] -16.80 < .001 Pearson 757
LIE_Frequency LIE_Contextuality -0.15 [-0.22, -0.08] -4.15 < .001 Pearson 757
LIE_Frequency IPIP6_Extraversion 0.04 [-0.03, 0.11] 1.04 0.300 Pearson 757
LIE_Frequency IPIP6_Agreableness -0.10 [-0.17, -0.03] -2.90 0.004 Pearson 757
LIE_Frequency IPIP6_Conscientiousness -0.11 [-0.18, -0.04] -2.93 0.003 Pearson 757
LIE_Frequency IPIP6_Neuroticism 0.06 [-0.01, 0.13] 1.77 0.077 Pearson 757
LIE_Frequency IPIP6_Openness -0.08 [-0.15, 0.00] -2.10 0.036 Pearson 757
LIE_Frequency IPIP6_HonestyHumility -0.09 [-0.16, -0.02] -2.59 0.010 Pearson 757
LIE_Ability LIE_Negativity -0.15 [-0.22, -0.08] -4.30 < .001 Pearson 757
LIE_Ability LIE_Contextuality 0.33 [ 0.27, 0.39] 9.67 < .001 Pearson 757
LIE_Ability IPIP6_Extraversion 0.09 [ 0.02, 0.16] 2.39 0.017 Pearson 757
LIE_Ability IPIP6_Agreableness 0.01 [-0.06, 0.09] 0.40 0.686 Pearson 757
LIE_Ability IPIP6_Conscientiousness 0.02 [-0.05, 0.09] 0.47 0.642 Pearson 757
LIE_Ability IPIP6_Neuroticism -0.04 [-0.11, 0.03] -1.11 0.268 Pearson 757
LIE_Ability IPIP6_Openness 0.15 [ 0.08, 0.22] 4.19 < .001 Pearson 757
LIE_Ability IPIP6_HonestyHumility -0.11 [-0.18, -0.04] -2.94 0.003 Pearson 757
LIE_Negativity LIE_Contextuality -0.27 [-0.34, -0.21] -7.81 < .001 Pearson 757
LIE_Negativity IPIP6_Extraversion -0.08 [-0.15, -0.01] -2.25 0.024 Pearson 757
LIE_Negativity IPIP6_Agreableness 0.11 [ 0.04, 0.18] 2.98 0.003 Pearson 757
LIE_Negativity IPIP6_Conscientiousness 0.08 [ 0.01, 0.15] 2.11 0.035 Pearson 757
LIE_Negativity IPIP6_Neuroticism 0.02 [-0.05, 0.09] 0.50 0.616 Pearson 757
LIE_Negativity IPIP6_Openness -0.04 [-0.11, 0.03] -1.01 0.315 Pearson 757
LIE_Negativity IPIP6_HonestyHumility -0.15 [-0.22, -0.08] -4.09 < .001 Pearson 757
LIE_Contextuality IPIP6_Extraversion -0.11 [-0.18, -0.03] -2.93 0.004 Pearson 757
LIE_Contextuality IPIP6_Agreableness 7.88e-03 [-0.06, 0.08] 0.22 0.829 Pearson 757
LIE_Contextuality IPIP6_Conscientiousness 0.08 [ 0.01, 0.15] 2.31 0.021 Pearson 757
LIE_Contextuality IPIP6_Neuroticism 6.37e-03 [-0.06, 0.08] 0.17 0.861 Pearson 757
LIE_Contextuality IPIP6_Openness 9.42e-03 [-0.06, 0.08] 0.26 0.796 Pearson 757
LIE_Contextuality IPIP6_HonestyHumility -0.05 [-0.12, 0.02] -1.39 0.166 Pearson 757
IPIP6_Extraversion IPIP6_Agreableness 0.29 [ 0.22, 0.35] 8.29 < .001 Pearson 757
IPIP6_Extraversion IPIP6_Conscientiousness -0.08 [-0.15, -0.01] -2.14 0.032 Pearson 757
IPIP6_Extraversion IPIP6_Neuroticism -0.16 [-0.23, -0.09] -4.47 < .001 Pearson 757
IPIP6_Extraversion IPIP6_Openness 0.11 [ 0.04, 0.18] 3.11 0.002 Pearson 757
IPIP6_Extraversion IPIP6_HonestyHumility -0.32 [-0.38, -0.26] -9.30 < .001 Pearson 757
IPIP6_Agreableness IPIP6_Conscientiousness 0.07 [ 0.00, 0.15] 2.06 0.040 Pearson 757
IPIP6_Agreableness IPIP6_Neuroticism 0.11 [ 0.04, 0.18] 3.15 0.002 Pearson 757
IPIP6_Agreableness IPIP6_Openness 0.23 [ 0.16, 0.29] 6.37 < .001 Pearson 757
IPIP6_Agreableness IPIP6_HonestyHumility 0.18 [ 0.11, 0.25] 5.12 < .001 Pearson 757
IPIP6_Conscientiousness IPIP6_Neuroticism -0.16 [-0.22, -0.08] -4.32 < .001 Pearson 757
IPIP6_Conscientiousness IPIP6_Openness -0.08 [-0.15, -0.01] -2.20 0.028 Pearson 757
IPIP6_Conscientiousness IPIP6_HonestyHumility 0.02 [-0.05, 0.09] 0.50 0.615 Pearson 757
IPIP6_Neuroticism IPIP6_Openness -2.29e-03 [-0.07, 0.07] -0.06 0.950 Pearson 757
IPIP6_Neuroticism IPIP6_HonestyHumility -0.20 [-0.27, -0.13] -5.60 < .001 Pearson 757
IPIP6_Openness IPIP6_HonestyHumility 0.10 [ 0.03, 0.17] 2.81 0.005 Pearson 757
graphdata_ipip <- cor_ipip %>%
  filter(p < .001) %>%
  tidygraph::as_tbl_graph() %>%
  as.list()

graphdata_ipip$nodes$Questionnaire <- ifelse(stringr::str_detect(graphdata_ipip$nodes$name, "LIE_"),
                               "LIE", "Normal Personality")
graphdata_ipip$nodes$name <- stringr::str_remove(graphdata_ipip$nodes$name, "LIE_|IPIP6_")
graphdata_ipip$nodes$name <- stringr::str_replace(graphdata_ipip$nodes$name, "yH", "y /\nH")

ggm_ipip <- create_ggm(graphdata_ipip, title = "Normal Personality", layout="graphopt", node_size=40)
ggm_ipip

Pathological Personality (PID5)

cor_pid <- correlation::correlation(
  dplyr::select(df, dplyr::starts_with("LIE"), dplyr::starts_with("PID5"), -PID5_Pathology),
  partial = TRUE, p_adjust = "none")

parameters::parameters_table(cor_pid)
Parameter1 Parameter2 r 95% CI t(755) p Method n_Obs
LIE_Frequency LIE_Ability 0.27 [ 0.20, 0.33] 7.59 < .001 Pearson 757
LIE_Frequency LIE_Negativity -0.53 [-0.58, -0.48] -17.26 < .001 Pearson 757
LIE_Frequency LIE_Contextuality -0.16 [-0.23, -0.09] -4.40 < .001 Pearson 757
LIE_Frequency PID5_NegativeAffect 0.04 [-0.03, 0.11] 1.08 0.279 Pearson 757
LIE_Frequency PID5_Detachment 0.07 [ 0.00, 0.14] 1.95 0.051 Pearson 757
LIE_Frequency PID5_Antagonism 0.04 [-0.03, 0.11] 1.12 0.263 Pearson 757
LIE_Frequency PID5_Disinhibition 0.13 [ 0.05, 0.20] 3.48 < .001 Pearson 757
LIE_Frequency PID5_Psychoticism 3.80e-03 [-0.07, 0.08] 0.10 0.917 Pearson 757
LIE_Ability LIE_Negativity -0.15 [-0.22, -0.08] -4.07 < .001 Pearson 757
LIE_Ability LIE_Contextuality 0.34 [ 0.28, 0.40] 10.04 < .001 Pearson 757
LIE_Ability PID5_NegativeAffect -0.05 [-0.12, 0.02] -1.40 0.161 Pearson 757
LIE_Ability PID5_Detachment -0.05 [-0.12, 0.03] -1.26 0.209 Pearson 757
LIE_Ability PID5_Antagonism 0.19 [ 0.12, 0.26] 5.42 < .001 Pearson 757
LIE_Ability PID5_Disinhibition -0.07 [-0.14, 0.00] -1.88 0.061 Pearson 757
LIE_Ability PID5_Psychoticism -5.97e-03 [-0.08, 0.07] -0.16 0.870 Pearson 757
LIE_Negativity LIE_Contextuality -0.27 [-0.34, -0.21] -7.78 < .001 Pearson 757
LIE_Negativity PID5_NegativeAffect 0.11 [ 0.04, 0.18] 2.95 0.003 Pearson 757
LIE_Negativity PID5_Detachment -9.15e-03 [-0.08, 0.06] -0.25 0.801 Pearson 757
LIE_Negativity PID5_Antagonism -0.02 [-0.09, 0.05] -0.47 0.642 Pearson 757
LIE_Negativity PID5_Disinhibition -0.04 [-0.11, 0.03] -1.17 0.241 Pearson 757
LIE_Negativity PID5_Psychoticism 0.02 [-0.06, 0.09] 0.44 0.662 Pearson 757
LIE_Contextuality PID5_NegativeAffect 0.08 [ 0.01, 0.15] 2.29 0.022 Pearson 757
LIE_Contextuality PID5_Detachment 0.03 [-0.04, 0.10] 0.80 0.425 Pearson 757
LIE_Contextuality PID5_Antagonism -0.09 [-0.16, -0.02] -2.51 0.012 Pearson 757
LIE_Contextuality PID5_Disinhibition -0.06 [-0.13, 0.01] -1.66 0.098 Pearson 757
LIE_Contextuality PID5_Psychoticism 0.06 [-0.01, 0.13] 1.67 0.095 Pearson 757
PID5_NegativeAffect PID5_Detachment 0.17 [ 0.10, 0.24] 4.81 < .001 Pearson 757
PID5_NegativeAffect PID5_Antagonism 0.14 [ 0.07, 0.21] 3.87 < .001 Pearson 757
PID5_NegativeAffect PID5_Disinhibition 0.16 [ 0.09, 0.22] 4.34 < .001 Pearson 757
PID5_NegativeAffect PID5_Psychoticism 0.25 [ 0.18, 0.31] 6.96 < .001 Pearson 757
PID5_Detachment PID5_Antagonism 0.13 [ 0.06, 0.20] 3.69 < .001 Pearson 757
PID5_Detachment PID5_Disinhibition 0.07 [ 0.00, 0.14] 1.94 0.053 Pearson 757
PID5_Detachment PID5_Psychoticism 0.26 [ 0.19, 0.33] 7.42 < .001 Pearson 757
PID5_Antagonism PID5_Disinhibition 0.22 [ 0.15, 0.29] 6.26 < .001 Pearson 757
PID5_Antagonism PID5_Psychoticism 0.13 [ 0.05, 0.20] 3.48 < .001 Pearson 757
PID5_Disinhibition PID5_Psychoticism 0.36 [ 0.29, 0.42] 10.44 < .001 Pearson 757
graphdata_pid <- cor_pid %>%
  filter(p < .001) %>%
  tidygraph::as_tbl_graph() %>%
  as.list()

graphdata_pid$nodes$Questionnaire <- ifelse(stringr::str_detect(graphdata_pid$nodes$name, "LIE_"),
                               "LIE", "Pathological Personality")
graphdata_pid$nodes$name <- stringr::str_remove(graphdata_pid$nodes$name, "LIE_|PID5_")
graphdata_pid$nodes$name <- stringr::str_replace(graphdata_pid$nodes$name, "eA", "e\nA")

ggm_pid <- create_ggm(graphdata_pid, title = "Pathological Personality", layout="graphopt", node_size=40)
ggm_pid

Light Triad (LTS)

cor_lts <- correlation::correlation(
  dplyr::select(df, dplyr::starts_with("LIE"), dplyr::starts_with("LTS"), -LTS_General),
  partial = TRUE, p_adjust = "none")

parameters::parameters_table(cor_lts)
Parameter1 Parameter2 r 95% CI t(755) p Method n_Obs
LIE_Frequency LIE_Ability 0.27 [ 0.21, 0.34] 7.84 < .001 Pearson 757
LIE_Frequency LIE_Negativity -0.52 [-0.57, -0.47] -16.92 < .001 Pearson 757
LIE_Frequency LIE_Contextuality -0.16 [-0.22, -0.09] -4.32 < .001 Pearson 757
LIE_Frequency LTS_FaithInHumanity -0.11 [-0.18, -0.04] -3.00 0.003 Pearson 757
LIE_Frequency LTS_Humanism 0.03 [-0.04, 0.10] 0.88 0.381 Pearson 757
LIE_Frequency LTS_Kantianism 0.09 [ 0.02, 0.16] 2.55 0.011 Pearson 757
LIE_Ability LIE_Negativity -0.16 [-0.23, -0.09] -4.39 < .001 Pearson 757
LIE_Ability LIE_Contextuality 0.33 [ 0.26, 0.39] 9.47 < .001 Pearson 757
LIE_Ability LTS_FaithInHumanity 5.60e-03 [-0.07, 0.08] 0.15 0.878 Pearson 757
LIE_Ability LTS_Humanism -0.04 [-0.11, 0.03] -1.03 0.302 Pearson 757
LIE_Ability LTS_Kantianism 9.49e-03 [-0.06, 0.08] 0.26 0.794 Pearson 757
LIE_Negativity LIE_Contextuality -0.28 [-0.35, -0.22] -8.10 < .001 Pearson 757
LIE_Negativity LTS_FaithInHumanity -0.06 [-0.13, 0.01] -1.70 0.090 Pearson 757
LIE_Negativity LTS_Humanism -0.06 [-0.13, 0.01] -1.77 0.078 Pearson 757
LIE_Negativity LTS_Kantianism -0.12 [-0.19, -0.04] -3.19 0.001 Pearson 757
LIE_Contextuality LTS_FaithInHumanity 4.30e-03 [-0.07, 0.08] 0.12 0.906 Pearson 757
LIE_Contextuality LTS_Humanism -0.10 [-0.17, -0.03] -2.72 0.007 Pearson 757
LIE_Contextuality LTS_Kantianism -0.04 [-0.11, 0.03] -1.08 0.281 Pearson 757
LTS_FaithInHumanity LTS_Humanism 0.47 [ 0.42, 0.53] 14.76 < .001 Pearson 757
LTS_FaithInHumanity LTS_Kantianism 0.16 [ 0.09, 0.23] 4.49 < .001 Pearson 757
LTS_Humanism LTS_Kantianism 0.28 [ 0.21, 0.34] 7.90 < .001 Pearson 757
graphdata_lts <- cor_lts %>%
  filter(p < .001) %>%
  tidygraph::as_tbl_graph() %>%
  as.list()

graphdata_lts$nodes$Questionnaire <- ifelse(stringr::str_detect(graphdata_lts$nodes$name, "LIE_"),
                               "LIE", "Light Triad")
graphdata_lts$nodes$name <- stringr::str_remove(graphdata_lts$nodes$name, "LIE_|LTS_")
graphdata_lts$nodes$name <- stringr::str_replace(graphdata_lts$nodes$name, "InH", " in\nH")

ggm_lts <- create_ggm(graphdata_lts, title = "Light Triad", layout="fr", bend=0.15)
ggm_lts

Impulsivity (UPPS)

cor_upps <- correlation::correlation(
  dplyr::select(df, dplyr::starts_with("LIE"), dplyr::starts_with("UPPS"), -UPPS_General),
  partial = TRUE, p_adjust = "none")

parameters::parameters_table(cor_upps)
Parameter1 Parameter2 r 95% CI t(755) p Method n_Obs
LIE_Frequency LIE_Ability 0.28 [ 0.21, 0.34] 7.90 < .001 Pearson 757
LIE_Frequency LIE_Negativity -0.52 [-0.57, -0.47] -16.81 < .001 Pearson 757
LIE_Frequency LIE_Contextuality -0.14 [-0.21, -0.07] -3.93 < .001 Pearson 757
LIE_Frequency UPPS_NegativeUrgency 0.06 [-0.01, 0.13] 1.76 0.079 Pearson 757
LIE_Frequency UPPS_PositiveUrgency 0.16 [ 0.09, 0.23] 4.38 < .001 Pearson 757
LIE_Frequency UPPS_LackOfPerseverance 0.04 [-0.03, 0.11] 1.17 0.241 Pearson 757
LIE_Frequency UPPS_LackOfPremeditation 0.01 [-0.06, 0.09] 0.41 0.683 Pearson 757
LIE_Frequency UPPS_SensationSeeking 3.92e-03 [-0.07, 0.08] 0.11 0.914 Pearson 757
LIE_Ability LIE_Negativity -0.16 [-0.23, -0.09] -4.58 < .001 Pearson 757
LIE_Ability LIE_Contextuality 0.31 [ 0.25, 0.37] 9.00 < .001 Pearson 757
LIE_Ability UPPS_NegativeUrgency 0.02 [-0.05, 0.09] 0.60 0.546 Pearson 757
LIE_Ability UPPS_PositiveUrgency -0.04 [-0.11, 0.03] -1.18 0.238 Pearson 757
LIE_Ability UPPS_LackOfPerseverance -0.02 [-0.09, 0.05] -0.46 0.643 Pearson 757
LIE_Ability UPPS_LackOfPremeditation -0.04 [-0.11, 0.03] -1.03 0.301 Pearson 757
LIE_Ability UPPS_SensationSeeking 0.07 [ 0.00, 0.14] 2.04 0.041 Pearson 757
LIE_Negativity LIE_Contextuality -0.29 [-0.35, -0.22] -8.29 < .001 Pearson 757
LIE_Negativity UPPS_NegativeUrgency 0.10 [ 0.03, 0.17] 2.75 0.006 Pearson 757
LIE_Negativity UPPS_PositiveUrgency 0.03 [-0.05, 0.10] 0.71 0.476 Pearson 757
LIE_Negativity UPPS_LackOfPerseverance -0.08 [-0.15, -0.01] -2.15 0.032 Pearson 757
LIE_Negativity UPPS_LackOfPremeditation -0.15 [-0.21, -0.08] -4.05 < .001 Pearson 757
LIE_Negativity UPPS_SensationSeeking 0.03 [-0.04, 0.10] 0.82 0.412 Pearson 757
LIE_Contextuality UPPS_NegativeUrgency 0.03 [-0.04, 0.10] 0.84 0.402 Pearson 757
LIE_Contextuality UPPS_PositiveUrgency -0.01 [-0.08, 0.06] -0.29 0.770 Pearson 757
LIE_Contextuality UPPS_LackOfPerseverance -0.08 [-0.15, 0.00] -2.09 0.037 Pearson 757
LIE_Contextuality UPPS_LackOfPremeditation -0.10 [-0.17, -0.03] -2.84 0.005 Pearson 757
LIE_Contextuality UPPS_SensationSeeking 0.07 [ 0.00, 0.14] 2.00 0.046 Pearson 757
UPPS_NegativeUrgency UPPS_PositiveUrgency 0.58 [ 0.54, 0.63] 19.81 < .001 Pearson 757
UPPS_NegativeUrgency UPPS_LackOfPerseverance -0.01 [-0.08, 0.06] -0.33 0.738 Pearson 757
UPPS_NegativeUrgency UPPS_LackOfPremeditation 0.04 [-0.03, 0.12] 1.21 0.225 Pearson 757
UPPS_NegativeUrgency UPPS_SensationSeeking -0.14 [-0.21, -0.07] -3.82 < .001 Pearson 757
UPPS_PositiveUrgency UPPS_LackOfPerseverance 8.67e-03 [-0.06, 0.08] 0.24 0.812 Pearson 757
UPPS_PositiveUrgency UPPS_LackOfPremeditation 0.21 [ 0.14, 0.27] 5.81 < .001 Pearson 757
UPPS_PositiveUrgency UPPS_SensationSeeking 0.26 [ 0.19, 0.32] 7.27 < .001 Pearson 757
UPPS_LackOfPerseverance UPPS_LackOfPremeditation 0.38 [ 0.32, 0.44] 11.31 < .001 Pearson 757
UPPS_LackOfPerseverance UPPS_SensationSeeking -0.13 [-0.20, -0.06] -3.73 < .001 Pearson 757
UPPS_LackOfPremeditation UPPS_SensationSeeking 0.03 [-0.04, 0.10] 0.76 0.445 Pearson 757
graphdata_upps <- cor_upps %>%
  filter(p < .001) %>%
  tidygraph::as_tbl_graph() %>%
  as.list()

graphdata_upps$nodes$Questionnaire <- ifelse(stringr::str_detect(graphdata_upps$nodes$name, "LIE_"),
                               "LIE", "Impulsivity")
graphdata_upps$nodes$name <- stringr::str_remove(graphdata_upps$nodes$name, "LIE_|UPPS_")
graphdata_upps$nodes$name <- stringr::str_replace(graphdata_upps$nodes$name, "U", "\nU")
graphdata_upps$nodes$name <- stringr::str_replace(graphdata_upps$nodes$name, "OfP", " of\nP")
graphdata_upps$nodes$name <- stringr::str_replace(graphdata_upps$nodes$name, "nS", "n\nS")

ggm_upps <- create_ggm(graphdata_upps, title = "Impulsivity")
ggm_upps

Emotion Regulation (DERS)

cor_ders <- correlation::correlation(
  dplyr::select(df, dplyr::starts_with("LIE"), dplyr::starts_with("DERS"), -DERS_General),
  partial = TRUE, p_adjust = "none")

parameters::parameters_table(cor_ders)
Parameter1 Parameter2 r 95% CI t(755) p Method n_Obs
LIE_Frequency LIE_Ability 0.28 [ 0.21, 0.34] 7.92 < .001 Pearson 757
LIE_Frequency LIE_Negativity -0.56 [-0.60, -0.51] -18.46 < .001 Pearson 757
LIE_Frequency LIE_Contextuality -0.15 [-0.22, -0.08] -4.11 < .001 Pearson 757
LIE_Frequency DERS_Awareness 0.04 [-0.03, 0.11] 1.04 0.297 Pearson 757
LIE_Frequency DERS_Clarity 0.10 [ 0.03, 0.17] 2.85 0.005 Pearson 757
LIE_Frequency DERS_Goals -0.06 [-0.13, 0.01] -1.76 0.078 Pearson 757
LIE_Frequency DERS_Impulse 0.13 [ 0.05, 0.19] 3.47 < .001 Pearson 757
LIE_Frequency DERS_NonAcceptance 0.09 [ 0.02, 0.16] 2.58 0.010 Pearson 757
LIE_Frequency DERS_Strategies 6.35e-03 [-0.06, 0.08] 0.17 0.861 Pearson 757
LIE_Ability LIE_Negativity -0.15 [-0.22, -0.08] -4.26 < .001 Pearson 757
LIE_Ability LIE_Contextuality 0.33 [ 0.26, 0.39] 9.50 < .001 Pearson 757
LIE_Ability DERS_Awareness -0.06 [-0.13, 0.01] -1.67 0.096 Pearson 757
LIE_Ability DERS_Clarity -0.06 [-0.14, 0.01] -1.78 0.075 Pearson 757
LIE_Ability DERS_Goals -0.04 [-0.11, 0.03] -1.18 0.240 Pearson 757
LIE_Ability DERS_Impulse 0.03 [-0.04, 0.10] 0.93 0.351 Pearson 757
LIE_Ability DERS_NonAcceptance 2.82e-03 [-0.07, 0.07] 0.08 0.938 Pearson 757
LIE_Ability DERS_Strategies 6.49e-03 [-0.06, 0.08] 0.18 0.859 Pearson 757
LIE_Negativity LIE_Contextuality -0.26 [-0.33, -0.19] -7.46 < .001 Pearson 757
LIE_Negativity DERS_Awareness -0.06 [-0.13, 0.01] -1.60 0.111 Pearson 757
LIE_Negativity DERS_Clarity 0.02 [-0.05, 0.09] 0.58 0.563 Pearson 757
LIE_Negativity DERS_Goals -0.04 [-0.11, 0.03] -1.10 0.273 Pearson 757
LIE_Negativity DERS_Impulse 0.06 [-0.01, 0.13] 1.70 0.090 Pearson 757
LIE_Negativity DERS_NonAcceptance 0.11 [ 0.04, 0.18] 3.08 0.002 Pearson 757
LIE_Negativity DERS_Strategies 2.58e-03 [-0.07, 0.07] 0.07 0.943 Pearson 757
LIE_Contextuality DERS_Awareness -0.05 [-0.12, 0.02] -1.39 0.166 Pearson 757
LIE_Contextuality DERS_Clarity -0.03 [-0.10, 0.04] -0.74 0.462 Pearson 757
LIE_Contextuality DERS_Goals 0.03 [-0.04, 0.10] 0.79 0.428 Pearson 757
LIE_Contextuality DERS_Impulse -0.01 [-0.09, 0.06] -0.40 0.689 Pearson 757
LIE_Contextuality DERS_NonAcceptance 6.61e-03 [-0.06, 0.08] 0.18 0.856 Pearson 757
LIE_Contextuality DERS_Strategies 0.02 [-0.06, 0.09] 0.43 0.670 Pearson 757
DERS_Awareness DERS_Clarity 0.28 [ 0.21, 0.34] 7.93 < .001 Pearson 757
DERS_Awareness DERS_Goals -0.19 [-0.26, -0.12] -5.39 < .001 Pearson 757
DERS_Awareness DERS_Impulse 0.06 [-0.02, 0.13] 1.53 0.125 Pearson 757
DERS_Awareness DERS_NonAcceptance -0.05 [-0.12, 0.02] -1.47 0.143 Pearson 757
DERS_Awareness DERS_Strategies 0.02 [-0.06, 0.09] 0.43 0.669 Pearson 757
DERS_Clarity DERS_Goals 0.03 [-0.04, 0.10] 0.82 0.410 Pearson 757
DERS_Clarity DERS_Impulse 0.10 [ 0.02, 0.17] 2.63 0.009 Pearson 757
DERS_Clarity DERS_NonAcceptance 0.17 [ 0.10, 0.24] 4.79 < .001 Pearson 757
DERS_Clarity DERS_Strategies 0.20 [ 0.13, 0.27] 5.61 < .001 Pearson 757
DERS_Goals DERS_Impulse 0.29 [ 0.22, 0.35] 8.22 < .001 Pearson 757
DERS_Goals DERS_NonAcceptance 0.17 [ 0.10, 0.24] 4.83 < .001 Pearson 757
DERS_Goals DERS_Strategies 0.23 [ 0.17, 0.30] 6.64 < .001 Pearson 757
DERS_Impulse DERS_NonAcceptance 0.07 [-0.01, 0.14] 1.79 0.074 Pearson 757
DERS_Impulse DERS_Strategies 0.46 [ 0.40, 0.52] 14.29 < .001 Pearson 757
DERS_NonAcceptance DERS_Strategies 0.22 [ 0.15, 0.29] 6.19 < .001 Pearson 757
graphdata_ders <- cor_ders %>%
  filter(p < .001) %>%
  tidygraph::as_tbl_graph() %>%
  as.list()

graphdata_ders$nodes$Questionnaire <- ifelse(stringr::str_detect(graphdata_ders$nodes$name, "LIE_"),
                               "LIE", "Emotion Regulation")
graphdata_ders$nodes$name <- stringr::str_remove(graphdata_ders$nodes$name, "LIE_|DERS_")
graphdata_ders$nodes$name <- stringr::str_replace(graphdata_ders$nodes$name, "nA", "n-\nA")

ggm_ders <- create_ggm(graphdata_ders, title = "Difficulties in Emotion Regulation")
ggm_ders

Interoception (MAIA2)

cor_maia <- correlation::correlation(
  dplyr::select(df, dplyr::starts_with("LIE"), dplyr::starts_with("MAIA2")),
  partial = TRUE, p_adjust = "none")

parameters::parameters_table(cor_maia)
Parameter1 Parameter2 r 95% CI t(755) p Method n_Obs
LIE_Frequency LIE_Ability 0.28 [ 0.21, 0.34] 7.91 < .001 Pearson 757
LIE_Frequency LIE_Negativity -0.54 [-0.59, -0.49] -17.86 < .001 Pearson 757
LIE_Frequency LIE_Contextuality -0.17 [-0.23, -0.10] -4.62 < .001 Pearson 757
LIE_Frequency MAIA2_Noticing -0.07 [-0.14, 0.00] -1.86 0.063 Pearson 757
LIE_Frequency MAIA2_BodyListening 0.10 [ 0.03, 0.17] 2.89 0.004 Pearson 757
LIE_Ability LIE_Negativity -0.16 [-0.23, -0.09] -4.52 < .001 Pearson 757
LIE_Ability LIE_Contextuality 0.33 [ 0.27, 0.39] 9.64 < .001 Pearson 757
LIE_Ability MAIA2_Noticing 0.08 [ 0.01, 0.15] 2.17 0.030 Pearson 757
LIE_Ability MAIA2_BodyListening -0.01 [-0.09, 0.06] -0.38 0.703 Pearson 757
LIE_Negativity LIE_Contextuality -0.27 [-0.33, -0.20] -7.58 < .001 Pearson 757
LIE_Negativity MAIA2_Noticing 0.05 [-0.02, 0.12] 1.36 0.173 Pearson 757
LIE_Negativity MAIA2_BodyListening 0.04 [-0.03, 0.11] 1.03 0.305 Pearson 757
LIE_Contextuality MAIA2_Noticing 1.15e-03 [-0.07, 0.07] 0.03 0.975 Pearson 757
LIE_Contextuality MAIA2_BodyListening 0.04 [-0.03, 0.11] 1.10 0.274 Pearson 757
MAIA2_Noticing MAIA2_BodyListening 0.56 [ 0.50, 0.60] 18.37 < .001 Pearson 757
graphdata_maia <- cor_maia %>%
  filter(p < .001) %>%
  tidygraph::as_tbl_graph() %>%
  as.list()

graphdata_maia$nodes$Questionnaire <- ifelse(stringr::str_detect(graphdata_maia$nodes$name, "LIE_"),
                               "LIE", "Interoception")
graphdata_maia$nodes$name <- stringr::str_remove(graphdata_maia$nodes$name, "LIE_|MAIA2_")
graphdata_maia$nodes$name <- stringr::str_replace(graphdata_maia$nodes$name, "yL", "y\nL")

ggm_maia <- create_ggm(graphdata_maia, title = "Interoception")
ggm_maia

References

report::cite_packages(sessionInfo())
>   - Ben-Shachar, Makowski & Lüdecke (2020). Compute and interpret indices of effect size. CRAN. Available from https://github.com/easystats/effectsize.
>   - Dirk Eddelbuettel and Romain Francois (2011). Rcpp: Seamless R and C++ Integration. Journal of Statistical Software, 40(8), 1-18. URL http://www.jstatsoft.org/v40/i08/.
>   - Goodrich B, Gabry J, Ali I & Brilleman S. (2020). rstanarm: Bayesian applied regression modeling via Stan. R package version 2.21.1 https://mc-stan.org/rstanarm.
>   - H. Wickham. ggplot2: Elegant Graphics for Data Analysis. Springer-Verlag New York, 2016.
>   - Hadley Wickham (2019). stringr: Simple, Consistent Wrappers for Common String Operations. R package version 1.4.0. https://CRAN.R-project.org/package=stringr
>   - Hadley Wickham (2020). forcats: Tools for Working with Categorical Variables (Factors). R package version 0.5.0. https://CRAN.R-project.org/package=forcats
>   - Hadley Wickham (2020). tidyr: Tidy Messy Data. R package version 1.1.2. https://CRAN.R-project.org/package=tidyr
>   - Hadley Wickham and Jim Hester (2020). readr: Read Rectangular Text Data. R package version 1.4.0. https://CRAN.R-project.org/package=readr
>   - Hadley Wickham, Romain François, Lionel Henry and Kirill Müller (2020). dplyr: A Grammar of Data Manipulation. R package version 1.0.2. https://CRAN.R-project.org/package=dplyr
>   - Kirill Müller and Hadley Wickham (2020). tibble: Simple Data Frames. R package version 3.0.4. https://CRAN.R-project.org/package=tibble
>   - Lionel Henry and Hadley Wickham (2020). purrr: Functional Programming Tools. R package version 0.3.4. https://CRAN.R-project.org/package=purrr
>   - Lüdecke D, Ben-Shachar M, Patil I, Makowski D (2020). "parameters:Extracting, Computing and Exploring the Parameters of StatisticalModels using R." _Journal of Open Source Software_, *5*(53), 2445. doi:10.21105/joss.02445 (URL: https://doi.org/10.21105/joss.02445).
>   - Lüdecke D, Waggoner P, Makowski D (2019). "insight: A Unified Interfaceto Access Information from Model Objects in R." _Journal of Open SourceSoftware_, *4*(38), 1412. doi: 10.21105/joss.01412 (URL:https://doi.org/10.21105/joss.01412).
>   - Lüdecke, Ben-Shachar, Waggoner & Makowski (2020). Visualisation Toolbox for 'easystats' and Extra Geoms, Themes and Color Palettes for 'ggplot2'. CRAN. Available from https://easystats.github.io/see/
>   - Lüdecke, Makowski, Waggoner & Patil (2020). Assessment of Regression Models Performance. CRAN. Available from https://easystats.github.io/performance/
>   - Makowski, D., Ben-Shachar, M. S. & Lüdecke, D. (2020). *Estimation of Model-Based Predictions, Contrasts and Means*. CRAN.
>   - Makowski, D., Ben-Shachar, M. S. & Lüdecke, D. (2020). *Estimation of Model-Based Predictions, Contrasts and Means*. GitHub.
>   - Makowski, D., Ben-Shachar, M. S., Patil, I., & Lüdecke, D. (2019). Methods and Algorithms for Correlation Analysis in R. Journal of Open Source Software, 5(51), 2306. 10.21105/joss.02306
>   - Makowski, D., Ben-Shachar, M., & Lüdecke, D. (2019). bayestestR: Describing Effects and their Uncertainty, Existence and Significance within the Bayesian Framework. Journal of Open Source Software, 4(40), 1541. doi:10.21105/joss.01541
>   - Makowski, D., Lüdecke, D., & Ben-Shachar, M.S. (2020). Automated reporting as a practical tool to improve reproducibility and methodological best practices adoption. CRAN. Available from https://github.com/easystats/report. doi: .
>   - R Core Team (2020). R: A language and environment for statistical computing. R Foundation for Statistical Computing, Vienna, Austria. URL https://www.R-project.org/.
>   - Thomas Lin Pedersen (2020). ggforce: Accelerating 'ggplot2'. R package version 0.3.2. https://CRAN.R-project.org/package=ggforce
>   - Thomas Lin Pedersen (2020). ggraph: An Implementation of Grammar of Graphics for Graphs and Networks. R package version 2.0.3. https://CRAN.R-project.org/package=ggraph
>   - Thomas Lin Pedersen (2020). tidygraph: A Tidy API for Graph Manipulation. R package version 1.2.0. https://CRAN.R-project.org/package=tidygraph
>   - Wickham et al., (2019). Welcome to the tidyverse. Journal of Open Source Software, 4(43), 1686, https://doi.org/10.21105/joss.01686
>   - Yihui Xie (2020). knitr: A General-Purpose Package for Dynamic Report Generation in R. R package version 1.30.